diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,361 @@ +[0.12.2.0] — December 2024 + +* Bug fixes: + * [`Builder`: avoid unsound buffer reuse, introduced in `bytestring-0.11.5.0`](https://github.com/haskell/bytestring/pull/691) + * [Fix several bugs around the `byteString` family of `Builders`](https://github.com/haskell/bytestring/pull/671) + * [Make `Data.ByteString.Lazy.zipWith` properly lazy](https://github.com/haskell/bytestring/pull/668) +* API additions: + * [Add `instance IsList Builder`](https://github.com/haskell/bytestring/pull/672) + * [Add `instance NFData BufferRange` and `instance NFData Buffer`](https://github.com/haskell/bytestring/pull/680) + * [Export `toLazyByteString` from `Data.ByteString.Builder.Internal`](https://github.com/haskell/bytestring/pull/672) +* Performance improvements: + * [Remove another dead branch from `toStrict`](https://github.com/haskell/bytestring/pull/663) +* Miscellaneous: + * [Remove support for GHC < 8.4](https://github.com/haskell/bytestring/pull/682) + * Various documentation improvements ([1](https://github.com/haskell/bytestring/pull/683), [2](https://github.com/haskell/bytestring/pull/692)) + + +[0.12.2.0]: https://github.com/haskell/bytestring/compare/0.12.1.0...0.12.2.0 + +[0.12.1.0] — February 2024 + +* [Provisional support has been added for using `bytestring` with GHC's JavaScript back-end.](https://github.com/haskell/bytestring/pull/631) + * This support is relatively un-tested and un-optimised. There may be bugs! Please report any you discover to [`bytestring`'s issue tracker](https://github.com/haskell/bytestring/issues). + * The JavaScript back-end's limited support for the Haskell-C foreign function interface would previously result in many operations failing with errors like `ReferenceError: h$fps_count is not defined`. + * The new `pure-haskell` package flag allows the new fallback Haskell implementations (used to support the JavaScript backend) to be used on most other platforms as well. +* Bug fixes: + * [`stimes 0 sbs :: ShortByteString` now returns the empty `ShortByteString` instead of throwing an exception](https://github.com/haskell/bytestring/pull/611) + * [`stimes 0 b :: Builder` now returns the empty `Builder` instead of throwing an exception](https://github.com/haskell/bytestring/pull/611) + * [Several alignment-related bug fixes](https://github.com/haskell/bytestring/pull/587) + * [Fix a bug in `isValidUtf8`](https://github.com/haskell/bytestring/pull/621) + * [`sconcat @ShortByteString` is no longer terribly inefficient](https://github.com/haskell/bytestring/pull/650) + * [Fix the type on the foreign import used for `Data.ByteString.Short.elemIndex`](https://github.com/haskell/bytestring/pull/661) + * [Ensure that the result of `fromShort` is protected by `mkDeferredByteString`](https://github.com/haskell/bytestring/pull/662) +* Behavior changes: + * [The `Data.Data.Data` instances for `StrictByteString` and `LazyByteString` have been changed:](https://github.com/haskell/bytestring/pull/614) + * `toConstr` now returns the a `pack` pseudo-constructor instead of throwing an exception. + * Due to this pseudo-constructor, `gunfold` can now be meaningfully used at these types. (Previously, it would always raise an exception.) + * These changes allow `syb:Data.Generics.Text.gshow` to be meaningfully used at types containing `ByteString`s. + * [A derived `instance Generic ShortByteString` has been added.](https://github.com/haskell/bytestring/pull/662) + * [`sconcat @Builder` is now lazy in the tail of its input](https://github.com/haskell/bytestring/pull/650) +* Deprecations: + * [`Data.ByteString.Builder.Prim.Internal.storableToF`](https://github.com/haskell/bytestring/pull/649) +* Performance improvements: + * Various raw-binary `Builder` primitives like `intHost` or `word32BE` are much less inefficient on architectures not known to support unaligned writes. ([1](https://github.com/haskell/bytestring/pull/587), [2](https://github.com/haskell/bytestring/pull/645)) + * [Hexadecimal encoding suffers one indirection fewer](https://github.com/haskell/bytestring/pull/624) + * [`Data.ByteString.Lazy.takeEnd` is somewhat faster](https://github.com/haskell/bytestring/pull/629) + * [`Data.ByteString.Lazy.dropEnd` is much faster](https://github.com/haskell/bytestring/pull/629) +* Miscellaneous: + * Various documentation improvements ([1](https://github.com/haskell/bytestring/pull/628), [2](https://github.com/haskell/bytestring/pull/609), [3](https://github.com/haskell/bytestring/pull/612), [4](https://github.com/haskell/bytestring/pull/623), [5](https://github.com/haskell/bytestring/pull/654)) + * [Eta-expand `Data.ByteString.Builder.Internal.empty`](https://github.com/haskell/bytestring/pull/616) + * This can variously help or hurt performance; it undoes the performance changes caused by [CLC proposal 132](https://github.com/haskell/core-libraries-committee/issues/132) with ghc-9.8 and restores the baseline performance seen with older GHCs. + + +[0.12.1.0]: https://github.com/haskell/bytestring/compare/0.12.0.2...0.12.1.0 + +[0.12.0.2] — August 2023 + +* Bug fixes: + * [Fix `clockid_t`-related build failures on some platforms](https://github.com/haskell/bytestring/pull/607) + +[0.12.0.2]: https://github.com/haskell/bytestring/compare/0.12.0.1...0.12.0.2 + +[0.12.0.1] — August 2023 + +* Bug fixes: + * [Work around a GHC runtime linker issue on i386/PowerPC](https://github.com/haskell/bytestring/pull/604) + +[0.12.0.1]: https://github.com/haskell/bytestring/compare/0.12.0.0...0.12.0.1 + +[0.12.0.0] — July 2023 + +* __Breaking Changes__: + * [`readInt` returns `Nothing`, if the sequence of digits cannot be represented by an `Int`, instead of overflowing silently](https://github.com/haskell/bytestring/pull/309) + * [Remove `zipWith` rewrite rule](https://github.com/haskell/bytestring/pull/387) + * [`ShortByteString` is now a wrapper around `Data.Array.Byte.ByteArray` instead of `ByteArray#` directly](https://github.com/haskell/bytestring/pull/410) + * As a compatibility measure, `SBS` remains available as a pattern synonym. + * The compatibility package `data-array-byte` is used when `base` does not provide `Data.Array.Byte`. + * [`fromListN` from `instance IsList ShortByteString` now throws an exception if the first argument does not match the length of the second](https://github.com/haskell/bytestring/pull/410) + * Previously, it would ignore the first argument entirely. +* Bug fixes: + * Size-related calculations are more resistant to `Int` overflow in the following places: + * [`Data.ByteString.intercalate`](https://github.com/haskell/bytestring/pull/468) + * [`stimes @StrictByteString`](https://github.com/haskell/bytestring/pull/443) + * [`Data.ByteString.Short.concat`](https://github.com/haskell/bytestring/pull/443) + * [`Data.ByteString.Short.append`](https://github.com/haskell/bytestring/pull/443) + * [`Data.ByteString.Short.snoc`](https://github.com/haskell/bytestring/pull/599) + * [`Data.ByteString.Short.cons`](https://github.com/haskell/bytestring/pull/599) +* API additions: + * [New sized and/or unsigned variants of `readInt` and `readInteger`](https://github.com/haskell/bytestring/pull/438) + * [`Data.ByteString.Internal` now provides `SizeOverflowException`, `overflowError`, and `checkedMultiply`](https://github.com/haskell/bytestring/pull/443) +* Deprecations: + * `Data.ByteString.getLine`: prefer `Data.ByteString.Char8.getLine` + * `Data.ByteString.hGetLine`: prefer `Data.ByteString.Char8.hGetLine` + + +[0.12.0.0]: https://github.com/haskell/bytestring/compare/0.11.5.0...0.12.0.0 + +[0.11.5.3] — October 2023 + +* Bug fixes: + * [Fix a bug in `isValidUtf8`](https://github.com/haskell/bytestring/pull/621) + +[0.11.5.3]: https://github.com/haskell/bytestring/compare/0.11.5.2...0.11.5.3 + +[0.11.5.2] — August 2023 + +* Bug fixes: + * [Fix `clockid_t`-related build failures on some platforms](https://github.com/haskell/bytestring/pull/607) + +[0.11.5.2]: https://github.com/haskell/bytestring/compare/0.11.5.1...0.11.5.2 + +[0.11.5.1] — August 2023 + +* Bug fixes: + * [Work around a GHC runtime linker issue on i386/PowerPC](https://github.com/haskell/bytestring/pull/604) + +[0.11.5.1]: https://github.com/haskell/bytestring/compare/0.11.5.0...0.11.5.1 + +[0.11.5.0] — July 2023 + +* Bug fixes: + * [Fix multiple bugs with ASCII blocks in the SIMD implementations for `isValidUtf8`](https://github.com/haskell/bytestring/pull/582) + * [Prevent unsound optimizations with the `Data.ByteString.Internal.create*` family of functions](https://github.com/haskell/bytestring/pull/580) +* API additions: + * [`Data.ByteString.Internal` now provides `mkDeferredByteString` and `deferForeignPtrAvailability`](https://github.com/haskell/bytestring/pull/580) +* Deprecations: + * `Data.ByteString.Internal.memcpy`: prefer `Foreign.Marshal.Utils.copyBytes` + * `Data.ByteString.Internal.memset`: prefer `Foreign.Marshal.Utils.fillBytes` +* Performance improvements: + * [Many functions returning `StrictByteString` can now return their results unboxed](https://github.com/haskell/bytestring/pull/580) + * [Dead branches removed from `Lazy.toStrict`](https://github.com/haskell/bytestring/pull/590) + * [`Builder.toLazyByteString` re-uses under-filled buffers after copying their contents](https://github.com/haskell/bytestring/pull/581) +* Miscellaneous: + * [Minor benchmarking improvements](https://github.com/haskell/bytestring/pull/577) + + +[0.11.5.0]: https://github.com/haskell/bytestring/compare/0.11.4.0...0.11.5.0 + +[0.11.4.0] — January 2023 + +* Bug fixes: + * [Prevent commoning-up of `ShortByteString` literals produced by `TemplateHaskell`](https://github.com/haskell/bytestring/pull/542) + * [Make `Builder` literals demand a sane amount of memory at chunk boundaries](https://github.com/haskell/bytestring/pull/538) +* API additions and behavior changes: + * [Export `unsafeIndex` for `ShortByteString` which had been accidentally removed in v0.11.3.0](https://github.com/haskell/bytestring/pull/532) + * [Make `Data.ByteString.Lazy.Char8.lines` less strict](https://github.com/haskell/bytestring/pull/562) + * [Add `NonEmpty` variants of `inits` and `tails`](https://github.com/haskell/bytestring/pull/557) +* Performance improvements: + * [Speed up `unpack` and folds for `ShortByteString`](https://github.com/haskell/bytestring/pull/526) + * [Speed up `Builder`s for non-host endianness](https://github.com/haskell/bytestring/pull/531) + * [Work around upstream `keepAlive#` performance regressions](https://github.com/haskell/bytestring/pull/536) + * [Improve performance of `uncons` for `LazyByteString`](https://github.com/haskell/bytestring/pull/559) + * [Simplify `useAsCString`](https://github.com/haskell/bytestring/pull/516) + * [Remove redundant comparisons in `Data.ByteString.Short.splitAt`](https://github.com/haskell/bytestring/pull/528) +* Miscellaneous: + * [Document possible interleaving of `hPutStrLn` and friends](https://github.com/haskell/bytestring/pull/518) + * [Documentation tweaks](https://github.com/haskell/bytestring/pull/523) + * [Add lower bound for `tasty-quickcheck`](https://github.com/haskell/bytestring/pull/520) + + +[0.11.4.0]: https://github.com/haskell/bytestring/compare/0.11.3.1...0.11.4.0 + +[0.11.3.1] — May 2022 + +* [Windows: Do not link against `gcc_s`](https://github.com/haskell/bytestring/pull/500) +* [Windows: Do not link against `gcc` when GHC >= 9.4](https://github.com/haskell/bytestring/pull/512) +* [Refine CPP for obsolete versions of `gcc`](https://github.com/haskell/bytestring/pull/505) + +[0.11.3.1]: https://github.com/haskell/bytestring/compare/0.11.3.0...0.11.3.1 + +[0.11.3.0] — February 2022 + +Erratum: `unsafeIndex` was accidentally removed from the export list of `Data.ByteString.Short.Internal` in this release. This was corrected in 0.11.4.0. + +* [Enhance `ShortByteString` API](https://github.com/haskell/bytestring/pull/471) + - Add `all`, `any`, `append`, `break`, `breakEnd`, `breakSubstring`, `concat`, `cons`, `count`, `drop`, `dropEnd`, `dropWhile`, `dropWhileEnd`, `elem`, `elemIndex`, `elemIndices`, `filter`, `find`, `findIndex`, `findIndices`, `foldl'`, `foldl`, `foldl1'`, `foldl1`, `foldr'`, `foldr`, `foldr1'`, `foldr1`, `head`, `init`, `intercalate`, `isInfixOf`, `isPrefixOf`, `isSuffixOf`, `last`, `map`, `partition`, `replicate`, `reverse`, `singleton`, `snoc`, `span`, `spanEnd`, `split`, `splitAt`, `splitWith`, `stripPrefix`, `stripSuffix`, `tail`, `take`, `takeEnd`, `takeWhile`, `takeWhileEnd`, `uncons`, `unfoldr`, `unfoldrN`, `unsnoc` to `Data.ByteString.Short`. +* [Add `Data.ByteString.Short.isValidUtf8`](https://github.com/haskell/bytestring/pull/450) +* [Use safe `isValidUtf8` for large inputs](https://github.com/haskell/bytestring/pull/470) +* [Make `unlines` lazier](https://github.com/haskell/bytestring/pull/477) +* [Improve performance of `unlines`](https://github.com/haskell/bytestring/pull/479) +* [Make `singleton` return a slice of a static buffer](https://github.com/haskell/bytestring/pull/480) +* [Improve performance of `intercalate`](https://github.com/haskell/bytestring/pull/459) + +[0.11.3.0]: https://github.com/haskell/bytestring/compare/0.11.2.0...0.11.3.0 + +[0.11.2.0] — December 2021 + +* [Add `Data.ByteString.isValidUtf8`](https://github.com/haskell/bytestring/pull/423) +* [Speed up `floatDec` and `doubleDec` using the Ryu algorithm](https://github.com/haskell/bytestring/pull/365) + - `Data.ByteString.Builder.RealFloat` offers additional custom formatters + for floating point numbers. +* [Add `StrictByteString` and `LazyByteString` type aliases](https://github.com/haskell/bytestring/pull/378) +* [Add `foldr'`, `foldr1'`, `scanl1`, `scanr`, `scanr1` to `Data.ByteString.Lazy{,.Char8}`](https://github.com/haskell/bytestring/pull/364) +* [Add `takeEnd`, `dropEnd`, `takeWhileEnd`, `dropWhileEnd`, `spanEnd`, `breakEnd` to `Data.ByteString.Lazy{,.Char8}`](https://github.com/haskell/bytestring/pull/395) +* [Add `Data.ByteString.Builder.writeFile` to write `Builder` to file directly](https://github.com/haskell/bytestring/pull/408) +* [Add `Data.ByteString.{from,to}FilePath` for encoding-aware conversions](https://github.com/haskell/bytestring/pull/403) +* [Add `Lift` instances for all flavors of `ByteString`](https://github.com/haskell/bytestring/pull/392) +* [Add `HasCallStack` for partial functions](https://github.com/haskell/bytestring/pull/440) +* [Define `foldl`, `foldl'`, `foldr`, `foldr'`, `mapAccumL`, `mapAccumR`, `scanl`, `scanr` and `filter` with one argument less to allow more inlining](https://github.com/haskell/bytestring/pull/345) +* [Speed up internal loop in `unfoldrN`](https://github.com/haskell/bytestring/pull/356) +* [Speed up `count` with SSE and AVX instructions](https://github.com/haskell/bytestring/pull/202) +* [Improve performance of certain `Builder`s by using a static table for Base16](https://github.com/haskell/bytestring/pull/418) +* [Use `unsafeWithForeignPtr` whenever possible](https://github.com/haskell/bytestring/pull/401) +* [Remove `integer-simple` flag](https://github.com/haskell/bytestring/pull/371) +* [Remove misleading mentions of fusion](https://github.com/haskell/bytestring/pull/412) + +[0.11.2.0]: https://github.com/haskell/bytestring/compare/0.11.1.0...0.11.2.0 + +[0.11.1.0] — February 2021 + +* [Add `Data.ByteString.Char8.findIndexEnd` and `Data.ByteString.Lazy.Char8.{elemIndexEnd,findIndexEnd,unzip}`](https://github.com/haskell/bytestring/pull/342) +* [Expose `ShortByteString` constructor from `Data.ByteString.Short`](https://github.com/haskell/bytestring/pull/313) +* [Add `compareLength` function, which is lazier than comparison of lengths](https://github.com/haskell/bytestring/pull/300) +* [Add strict `takeEnd` and `dropEnd`](https://github.com/haskell/bytestring/pull/290) +* [Expose `packZipWith` to zip two `ByteString`](https://github.com/haskell/bytestring/pull/295) +* [Add `instance Show Builder`](https://github.com/haskell/bytestring/pull/296) +* [Improve lazy `pack` to carry fewer arguments in the inner loop](https://github.com/haskell/bytestring/pull/292) +* [Improve `map`, `findIndex` and `findIndexEnd` to carry fewer arguments in the inner loop](https://github.com/haskell/bytestring/pull/347) +* [Improve lazy `{take,drop}While`, `break` and `group{,By}` to carry fewer arguments in the inner loop](https://github.com/haskell/bytestring/pull/337) +* [Speed up `intersperse` using SSE2 instructions](https://github.com/haskell/bytestring/pull/310) +* [`fromShort` does not reallocate its argument, if it is pinned](https://github.com/haskell/bytestring/pull/317) +* [Speed up `words` using a faster test for spaces](https://github.com/haskell/bytestring/pull/315) +* [Implement `stimes` more efficiently than default definition](https://github.com/haskell/bytestring/pull/301) + +[0.11.1.0]: https://github.com/haskell/bytestring/compare/0.11.0.0...0.11.1.0 + +[0.10.12.1] – January 2021 + +* [Replace `withForeignPtr` with `unsafeWithForeignPtr` where appropriate](https://github.com/haskell/bytestring/pull/333) + +[0.10.12.1]: https://github.com/haskell/bytestring/compare/0.10.12.0...0.10.12.1 + +[0.11.0.0] — September 2020 + * [Change internal representation of `ByteString`, removing offset](https://github.com/haskell/bytestring/pull/175) + * The old `PS` constructor has been turned into a pattern synonym that is available with GHC >= 8.0 for backwards compatibility. Consider adding `if !impl(ghc >=8.0) { build-depends: bytestring < 0.11 }` to packages, which use `PS` and still support GHC < 8.0. + * [Fill `ForeignPtrContents` of `nullForeignPtr` with `FinalPtr` instead of a bottom](https://github.com/haskell/bytestring/pull/284) + * [Remove deprecated functions `findSubstring` and `findSubstrings`](https://github.com/haskell/bytestring/pull/181) + * [Speed up sorting of short strings](https://github.com/haskell/bytestring/pull/267) + * [Improve handling of literal strings in `Data.ByteString.Builder`](https://github.com/haskell/bytestring/pull/132) + * [Compute length at compile time for literal strings](https://github.com/haskell/bytestring/pull/191) + * This improves optimization opportunities for functions that scrutinize the length of a `ByteString`. + * [Add `indexMaybe` and synonym `(!?)` for indexing that returns `Maybe`](https://github.com/haskell/bytestring/pull/261) + * [Add rewrite rules for `{take,drop}While ({=,/}= x)`](https://github.com/haskell/bytestring/pull/275) + * [Add rewrite rules for `any (== x)` and `all (/= x)`](https://github.com/haskell/bytestring/pull/273) + * [Add rewrite rules for `findInd{ex,ices} (== x)`](https://github.com/haskell/bytestring/pull/270) + * [Improve folds to pass fewer arguments on each recursive invocation](https://github.com/haskell/bytestring/pull/273) + * [Improve performance of `findIndices`](https://github.com/haskell/bytestring/pull/270) + * [Re-export `Data.ByteString.Lazy.{from,to}Strict` from `Data.ByteString`](https://github.com/haskell/bytestring/pull/281) + * [Remove deprecated modules and functions](https://github.com/haskell/bytestring/pull/286) + * Use `Data.ByteString.Builder{,.Extra}` instead of `Data.ByteString.Lazy.Builder{,.ASCII,.Extras}`. + * Use `Data.ByteString.Char8.{,h}putStrLn` instead of `Data.ByteString.{,h}putStrLn` and `Data.ByteString.Lazy.Char8.putStrLn` instead of `Data.ByteString.Char8.putStrLn`. + * Use `Data.ByteString.break (== x)` instead of `Data.ByteString.breakByte x`. + * Use `Data.ByteString.Internal.accursedUnutterablePerformIO` instead of `Data.ByteString.Internal.inlinePerformIO`. + +[0.11.0.0]: https://github.com/haskell/bytestring/compare/0.10.12.0...0.11.0.0 + +[0.10.12.0] – August 2020 + + * **Note:** There are several breaking changes planned to be included in v0.11. + Please ensure that your packages have appropriate upper bounds on bytestring, + in order to minimize avoidable breakage. + * [Add `takeWhileEnd` and `dropWhileEnd` to `Data.ByteString` and `Data.ByteString.Char8`, and add `dropSpace` and `strip` to `Data.ByteString.Char8`](https://github.com/haskell/bytestring/pull/121) + * [Add `findIndexEnd` to `Data.ByteString` and `Data.ByteString.Lazy`](https://github.com/haskell/bytestring/pull/155) + * [Add `partition` to `Data.ByteString.Char8` and `Data.ByteString.Lazy.Char8`](https://github.com/haskell/bytestring/pull/251) + * [Add `IsList` instances for strict and lazy `ByteString` and for `ShortByteString`](https://github.com/haskell/bytestring/pull/219) + * [Add `createUptoN'` and `unsafeCreateUptoN'` to `Data.ByteString.Internal`](https://github.com/haskell/bytestring/pull/245) + * [Add `boundedPrim` to `Data.ByteString.Builder.Prim.Internal` and deprecate `boudedPrim`](https://github.com/haskell/bytestring/pull/246) + * [Deprecate the `Data.ByteString.Lazy.Builder` and `Data.ByteString.Lazy.Builder.{ASCII,Extras}` modules](https://github.com/haskell/bytestring/pull/250) + * [Fix documented complexity of `Data.ByteString.Lazy.length`](https://github.com/haskell/bytestring/pull/255) + * [Assorted documentation fixes](https://github.com/haskell/bytestring/pull/248) + +[0.10.12.0]: https://github.com/haskell/bytestring/compare/0.10.10.1...0.10.12.0 + +0.10.10.1 – June 2020 + + * Fix off-by-one infinite loop in primMapByteStringBounded ([#203]) + * Don't perform unaligned writes when it isn't known to be safe ([#133]) + * Improve the performance of sconcat for lazy and strict bytestrings ([#142]) + * Document inadvertent 0.10.6.0 behaviour change in findSubstrings + * Fix benchmark builds ([#52]) + * Documentation fixes + * Test fixes + +[#52]: https://github.com/haskell/bytestring/issues/52 +[#133]: https://github.com/haskell/bytestring/pull/133 +[#142]: https://github.com/haskell/bytestring/pull/142 +[#203]: https://github.com/haskell/bytestring/issues/203 + +0.10.10.0 July 2019 July 2019 + + * Build with GHC 8.8, and tests with QC 2.10+ + * Add conversions between ShortByteString and CString (#126) + * Documentation fixes (#65, #118, #144, #150, #152, #172) + * Resolve potential copyright issue with test data (#165) + +0.10.8.2 Duncan Coutts Feb 2017 + + * Make readFile work for files with no size like /dev/null + * Extend the cases in which concat and toStrict can avoid copying data + * Fix building with ghc-7.0 + * Minor documentation improvements + * Internal code cleanups + +0.10.8.1 Duncan Coutts May 2016 + + * Fix Builder output on big-endian architectures + * Fix building with ghc-7.6 and older + +0.10.8.0 Duncan Coutts May 2016 + + * Use Rabin-Karp substring search for `breakSubstring` and `findSubstring` + * Improve the performance of `partition` for lazy and strict bytestrings + * Added `stripPrefix` and `stripSuffix` for lazy and strict bytestrings + * Fix building with ghc 8.0 & base 4.9 (Semigroup etc) + +0.10.6.0 Duncan Coutts Mar 2015 + + * Rename inlinePerformIO so people don't misuse it + * Fix a corner case in unfoldrN + * Export isSuffixOf from D.B.Lazy.Char8 + * Add D.B.Lazy.elemIndexEnd + * Fix readFile for files with incorrectly reported file size + * Fix for builder performance with ghc 7.10 + * Fix building with ghc 6.12 + +0.10.4.1 Duncan Coutts Nov 2014 + + * Fix integer overflow in concatenation functions + * Fix strictness of lazy bytestring foldl' + * Numerous minor documentation fixes + * Various testsuite improvements diff --git a/Data/ByteString.hs b/Data/ByteString.hs --- a/Data/ByteString.hs +++ b/Data/ByteString.hs @@ -1,2026 +1,2090 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ -{-# LANGUAGE MagicHash, UnboxedTuples, - NamedFieldPuns, BangPatterns, RecordWildCards #-} -#endif -{-# OPTIONS_HADDOCK prune #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - --- | --- Module : Data.ByteString --- Copyright : (c) The University of Glasgow 2001, --- (c) David Roundy 2003-2005, --- (c) Simon Marlow 2005, --- (c) Bjorn Bringert 2006, --- (c) Don Stewart 2005-2008, --- (c) Duncan Coutts 2006-2011 --- License : BSD-style --- --- Maintainer : dons00@gmail.com, duncan@community.haskell.org --- Stability : stable --- Portability : portable --- --- A time and space-efficient implementation of byte vectors using --- packed Word8 arrays, suitable for high performance use, both in terms --- of large data quantities, or high speed requirements. Byte vectors --- are encoded as strict 'Word8' arrays of bytes, held in a 'ForeignPtr', --- and can be passed between C and Haskell with little effort. --- --- This module is intended to be imported @qualified@, to avoid name --- clashes with "Prelude" functions. eg. --- --- > import qualified Data.ByteString as B --- --- Original GHC implementation by Bryan O\'Sullivan. --- Rewritten to use 'Data.Array.Unboxed.UArray' by Simon Marlow. --- Rewritten to support slices and use 'ForeignPtr' by David Roundy. --- Rewritten again and extended by Don Stewart and Duncan Coutts. --- - -module Data.ByteString ( - - -- * The @ByteString@ type - ByteString, -- abstract, instances: Eq, Ord, Show, Read, Data, Typeable, Monoid - - -- * Introducing and eliminating 'ByteString's - empty, -- :: ByteString - singleton, -- :: Word8 -> ByteString - pack, -- :: [Word8] -> ByteString - unpack, -- :: ByteString -> [Word8] - - -- * Basic interface - cons, -- :: Word8 -> ByteString -> ByteString - snoc, -- :: ByteString -> Word8 -> ByteString - append, -- :: ByteString -> ByteString -> ByteString - head, -- :: ByteString -> Word8 - uncons, -- :: ByteString -> Maybe (Word8, ByteString) - last, -- :: ByteString -> Word8 - tail, -- :: ByteString -> ByteString - init, -- :: ByteString -> ByteString - null, -- :: ByteString -> Bool - length, -- :: ByteString -> Int - - -- * Transforming ByteStrings - map, -- :: (Word8 -> Word8) -> ByteString -> ByteString - reverse, -- :: ByteString -> ByteString - intersperse, -- :: Word8 -> ByteString -> ByteString - intercalate, -- :: ByteString -> [ByteString] -> ByteString - transpose, -- :: [ByteString] -> [ByteString] - - -- * Reducing 'ByteString's (folds) - foldl, -- :: (a -> Word8 -> a) -> a -> ByteString -> a - foldl', -- :: (a -> Word8 -> a) -> a -> ByteString -> a - foldl1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 - foldl1', -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 - - foldr, -- :: (Word8 -> a -> a) -> a -> ByteString -> a - foldr', -- :: (Word8 -> a -> a) -> a -> ByteString -> a - foldr1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 - foldr1', -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 - - -- ** Special folds - concat, -- :: [ByteString] -> ByteString - concatMap, -- :: (Word8 -> ByteString) -> ByteString -> ByteString - any, -- :: (Word8 -> Bool) -> ByteString -> Bool - all, -- :: (Word8 -> Bool) -> ByteString -> Bool - maximum, -- :: ByteString -> Word8 - minimum, -- :: ByteString -> Word8 - - -- * Building ByteStrings - -- ** Scans - scanl, -- :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString - scanl1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString - scanr, -- :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString - scanr1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString - - -- ** Accumulating maps - mapAccumL, -- :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) - mapAccumR, -- :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) - - -- ** Generating and unfolding ByteStrings - replicate, -- :: Int -> Word8 -> ByteString - unfoldr, -- :: (a -> Maybe (Word8, a)) -> a -> ByteString - unfoldrN, -- :: Int -> (a -> Maybe (Word8, a)) -> a -> (ByteString, Maybe a) - - -- * Substrings - - -- ** Breaking strings - take, -- :: Int -> ByteString -> ByteString - drop, -- :: Int -> ByteString -> ByteString - splitAt, -- :: Int -> ByteString -> (ByteString, ByteString) - takeWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString - dropWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString - span, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) - spanEnd, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) - break, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) - breakEnd, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) - group, -- :: ByteString -> [ByteString] - groupBy, -- :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString] - inits, -- :: ByteString -> [ByteString] - tails, -- :: ByteString -> [ByteString] - - -- ** Breaking into many substrings - split, -- :: Word8 -> ByteString -> [ByteString] - splitWith, -- :: (Word8 -> Bool) -> ByteString -> [ByteString] - - -- * Predicates - isPrefixOf, -- :: ByteString -> ByteString -> Bool - isSuffixOf, -- :: ByteString -> ByteString -> Bool - isInfixOf, -- :: ByteString -> ByteString -> Bool - - -- ** Search for arbitrary substrings - breakSubstring, -- :: ByteString -> ByteString -> (ByteString,ByteString) - findSubstring, -- :: ByteString -> ByteString -> Maybe Int - findSubstrings, -- :: ByteString -> ByteString -> [Int] - - -- * Searching ByteStrings - - -- ** Searching by equality - elem, -- :: Word8 -> ByteString -> Bool - notElem, -- :: Word8 -> ByteString -> Bool - - -- ** Searching with a predicate - find, -- :: (Word8 -> Bool) -> ByteString -> Maybe Word8 - filter, -- :: (Word8 -> Bool) -> ByteString -> ByteString - partition, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) - - -- * Indexing ByteStrings - index, -- :: ByteString -> Int -> Word8 - elemIndex, -- :: Word8 -> ByteString -> Maybe Int - elemIndices, -- :: Word8 -> ByteString -> [Int] - elemIndexEnd, -- :: Word8 -> ByteString -> Maybe Int - findIndex, -- :: (Word8 -> Bool) -> ByteString -> Maybe Int - findIndices, -- :: (Word8 -> Bool) -> ByteString -> [Int] - count, -- :: Word8 -> ByteString -> Int - - -- * Zipping and unzipping ByteStrings - zip, -- :: ByteString -> ByteString -> [(Word8,Word8)] - zipWith, -- :: (Word8 -> Word8 -> c) -> ByteString -> ByteString -> [c] - unzip, -- :: [(Word8,Word8)] -> (ByteString,ByteString) - - -- * Ordered ByteStrings - sort, -- :: ByteString -> ByteString - - -- * Low level conversions - -- ** Copying ByteStrings - copy, -- :: ByteString -> ByteString - - -- ** Packing 'CString's and pointers - packCString, -- :: CString -> IO ByteString - packCStringLen, -- :: CStringLen -> IO ByteString - - -- ** Using ByteStrings as 'CString's - useAsCString, -- :: ByteString -> (CString -> IO a) -> IO a - useAsCStringLen, -- :: ByteString -> (CStringLen -> IO a) -> IO a - - -- * I\/O with 'ByteString's - - -- ** Standard input and output - getLine, -- :: IO ByteString - getContents, -- :: IO ByteString - putStr, -- :: ByteString -> IO () - putStrLn, -- :: ByteString -> IO () - interact, -- :: (ByteString -> ByteString) -> IO () - - -- ** Files - readFile, -- :: FilePath -> IO ByteString - writeFile, -- :: FilePath -> ByteString -> IO () - appendFile, -- :: FilePath -> ByteString -> IO () - - -- ** I\/O with Handles - hGetLine, -- :: Handle -> IO ByteString - hGetContents, -- :: Handle -> IO ByteString - hGet, -- :: Handle -> Int -> IO ByteString - hGetSome, -- :: Handle -> Int -> IO ByteString - hGetNonBlocking, -- :: Handle -> Int -> IO ByteString - hPut, -- :: Handle -> ByteString -> IO () - hPutNonBlocking, -- :: Handle -> ByteString -> IO ByteString - hPutStr, -- :: Handle -> ByteString -> IO () - hPutStrLn, -- :: Handle -> ByteString -> IO () - - breakByte - - ) where - -import qualified Prelude as P -import Prelude hiding (reverse,head,tail,last,init,null - ,length,map,lines,foldl,foldr,unlines - ,concat,any,take,drop,splitAt,takeWhile - ,dropWhile,span,break,elem,filter,maximum - ,minimum,all,concatMap,foldl1,foldr1 - ,scanl,scanl1,scanr,scanr1 - ,readFile,writeFile,appendFile,replicate - ,getContents,getLine,putStr,putStrLn,interact - ,zip,zipWith,unzip,notElem) - -import Data.ByteString.Internal -import Data.ByteString.Unsafe - -import qualified Data.List as List - -import Data.Word (Word8) -import Data.Maybe (isJust, listToMaybe) - --- Control.Exception.assert not available in yhc or nhc -#ifndef __NHC__ -import Control.Exception (finally, bracket, assert, throwIO) -#else -import Control.Exception (bracket, finally) -#endif -import Control.Monad (when) - -import Foreign.C.String (CString, CStringLen) -import Foreign.C.Types (CSize) -import Foreign.ForeignPtr -import Foreign.Marshal.Alloc (allocaBytes, mallocBytes, reallocBytes, finalizerFree) -import Foreign.Marshal.Array (allocaArray) -import Foreign.Ptr -import Foreign.Storable (Storable(..)) - --- hGetBuf and hPutBuf not available in yhc or nhc -import System.IO (stdin,stdout,hClose,hFileSize - ,hGetBuf,hPutBuf,openBinaryFile - ,IOMode(..)) -import System.IO.Error (mkIOError, illegalOperationErrorType) - -import Data.Monoid (Monoid(..)) - -#if !defined(__GLASGOW_HASKELL__) -import System.IO.Unsafe -import qualified System.Environment -import qualified System.IO (hGetLine) -import System.IO (hIsEOF) -#endif - -#if defined(__GLASGOW_HASKELL__) - -import System.IO (hGetBufNonBlocking, hPutBufNonBlocking) - -#if MIN_VERSION_base(4,3,0) -import System.IO (hGetBufSome) -#else -import System.IO (hWaitForInput, hIsEOF) -#endif - -#if __GLASGOW_HASKELL__ >= 611 -import Data.IORef -import GHC.IO.Handle.Internals -import GHC.IO.Handle.Types -import GHC.IO.Buffer -import GHC.IO.BufferedIO as Buffered -import GHC.IO (unsafePerformIO, unsafeDupablePerformIO) -import Data.Char (ord) -import Foreign.Marshal.Utils (copyBytes) -#else -import System.IO.Error (isEOFError) -import GHC.IOBase -import GHC.Handle -#endif - -import GHC.Prim (Word#) -import GHC.Base (build) -import GHC.Word hiding (Word8) - -#endif - --- An alternative to Control.Exception (assert) for nhc98 -#ifdef __NHC__ - -import System.IO (Handle) - -#define assert assertS "__FILE__ : __LINE__" -assertS :: String -> Bool -> a -> a -assertS _ True = id -assertS s False = error ("assertion failed at "++s) - --- An alternative to hWaitForInput -hWaitForInput :: Handle -> Int -> IO () -hWaitForInput _ _ = return () -#endif - -#ifndef __GLASGOW_HASKELL__ -unsafeDupablePerformIO = unsafePerformIO -#endif - --- ----------------------------------------------------------------------------- --- --- Useful macros, until we have bang patterns --- - -#define STRICT1(f) f a | a `seq` False = undefined -#define STRICT2(f) f a b | a `seq` b `seq` False = undefined -#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined -#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined -#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined - --- ----------------------------------------------------------------------------- --- Introducing and eliminating 'ByteString's - --- | /O(1)/ The empty 'ByteString' -empty :: ByteString -empty = PS nullForeignPtr 0 0 - --- | /O(1)/ Convert a 'Word8' into a 'ByteString' -singleton :: Word8 -> ByteString -singleton c = unsafeCreate 1 $ \p -> poke p c -{-# INLINE [1] singleton #-} - --- Inline [1] for intercalate rule - --- --- XXX The use of unsafePerformIO in allocating functions (unsafeCreate) is critical! --- --- Otherwise: --- --- singleton 255 `compare` singleton 127 --- --- is compiled to: --- --- case mallocByteString 2 of --- ForeignPtr f internals -> --- case writeWord8OffAddr# f 0 255 of _ -> --- case writeWord8OffAddr# f 0 127 of _ -> --- case eqAddr# f f of --- False -> case compare (GHC.Prim.plusAddr# f 0) --- (GHC.Prim.plusAddr# f 0) --- --- - --- | /O(n)/ Convert a '[Word8]' into a 'ByteString'. --- --- For applications with large numbers of string literals, pack can be a --- bottleneck. In such cases, consider using packAddress (GHC only). -pack :: [Word8] -> ByteString -pack = packBytes - --- | /O(n)/ Converts a 'ByteString' to a '[Word8]'. -unpack :: ByteString -> [Word8] -#if !defined(__GLASGOW_HASKELL__) -unpack = unpackBytes -#else - -unpack ps = build (unpackFoldr ps) -{-# INLINE unpack #-} - --- --- Have unpack fuse with good list consumers --- --- critical this isn't strict in the acc --- as it will break in the presence of list fusion. this is a known --- issue with seq and build/foldr rewrite rules, which rely on lazy --- demanding to avoid bottoms in the list. --- -unpackFoldr :: ByteString -> (Word8 -> a -> a) -> a -> a -unpackFoldr (PS fp off len) f ch = withPtr fp $ \p -> do - let loop q n _ | q `seq` n `seq` False = undefined -- n.b. - loop _ (-1) acc = return acc - loop q n acc = do - a <- peekByteOff q n - loop q (n-1) (a `f` acc) - loop (p `plusPtr` off) (len-1) ch -{-# INLINE [0] unpackFoldr #-} - -{-# RULES -"ByteString unpack-list" [1] forall p . - unpackFoldr p (:) [] = unpackBytes p - #-} - -#endif - --- --------------------------------------------------------------------- --- Basic interface - --- | /O(1)/ Test whether a ByteString is empty. -null :: ByteString -> Bool -null (PS _ _ l) = assert (l >= 0) $ l <= 0 -{-# INLINE null #-} - --- --------------------------------------------------------------------- --- | /O(1)/ 'length' returns the length of a ByteString as an 'Int'. -length :: ByteString -> Int -length (PS _ _ l) = assert (l >= 0) $ l -{-# INLINE length #-} - ------------------------------------------------------------------------- - -infixr 5 `cons` --same as list (:) -infixl 5 `snoc` - --- | /O(n)/ 'cons' is analogous to (:) for lists, but of different --- complexity, as it requires a memcpy. -cons :: Word8 -> ByteString -> ByteString -cons c (PS x s l) = unsafeCreate (l+1) $ \p -> withForeignPtr x $ \f -> do - poke p c - memcpy (p `plusPtr` 1) (f `plusPtr` s) (fromIntegral l) -{-# INLINE cons #-} - --- | /O(n)/ Append a byte to the end of a 'ByteString' -snoc :: ByteString -> Word8 -> ByteString -snoc (PS x s l) c = unsafeCreate (l+1) $ \p -> withForeignPtr x $ \f -> do - memcpy p (f `plusPtr` s) (fromIntegral l) - poke (p `plusPtr` l) c -{-# INLINE snoc #-} - --- todo fuse - --- | /O(1)/ Extract the first element of a ByteString, which must be non-empty. --- An exception will be thrown in the case of an empty ByteString. -head :: ByteString -> Word8 -head (PS x s l) - | l <= 0 = errorEmptyList "head" - | otherwise = inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p s -{-# INLINE head #-} - --- | /O(1)/ Extract the elements after the head of a ByteString, which must be non-empty. --- An exception will be thrown in the case of an empty ByteString. -tail :: ByteString -> ByteString -tail (PS p s l) - | l <= 0 = errorEmptyList "tail" - | otherwise = PS p (s+1) (l-1) -{-# INLINE tail #-} - --- | /O(1)/ Extract the head and tail of a ByteString, returning Nothing --- if it is empty. -uncons :: ByteString -> Maybe (Word8, ByteString) -uncons (PS x s l) - | l <= 0 = Nothing - | otherwise = Just (inlinePerformIO $ withForeignPtr x - $ \p -> peekByteOff p s, - PS x (s+1) (l-1)) -{-# INLINE uncons #-} - --- | /O(1)/ Extract the last element of a ByteString, which must be finite and non-empty. --- An exception will be thrown in the case of an empty ByteString. -last :: ByteString -> Word8 -last ps@(PS x s l) - | null ps = errorEmptyList "last" - | otherwise = inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p (s+l-1) -{-# INLINE last #-} - --- | /O(1)/ Return all the elements of a 'ByteString' except the last one. --- An exception will be thrown in the case of an empty ByteString. -init :: ByteString -> ByteString -init ps@(PS p s l) - | null ps = errorEmptyList "init" - | otherwise = PS p s (l-1) -{-# INLINE init #-} - --- | /O(n)/ Append two ByteStrings -append :: ByteString -> ByteString -> ByteString -append = mappend -{-# INLINE append #-} - --- --------------------------------------------------------------------- --- Transformations - --- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each --- element of @xs@. -map :: (Word8 -> Word8) -> ByteString -> ByteString -map f (PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> - create len $ map_ 0 (a `plusPtr` s) - where - map_ :: Int -> Ptr Word8 -> Ptr Word8 -> IO () - STRICT3(map_) - map_ n p1 p2 - | n >= len = return () - | otherwise = do - x <- peekByteOff p1 n - pokeByteOff p2 n (f x) - map_ (n+1) p1 p2 -{-# INLINE map #-} - --- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order. -reverse :: ByteString -> ByteString -reverse (PS x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f -> - c_reverse p (f `plusPtr` s) (fromIntegral l) - --- | /O(n)/ The 'intersperse' function takes a 'Word8' and a --- 'ByteString' and \`intersperses\' that byte between the elements of --- the 'ByteString'. It is analogous to the intersperse function on --- Lists. -intersperse :: Word8 -> ByteString -> ByteString -intersperse c ps@(PS x s l) - | length ps < 2 = ps - | otherwise = unsafeCreate (2*l-1) $ \p -> withForeignPtr x $ \f -> - c_intersperse p (f `plusPtr` s) (fromIntegral l) c - --- | The 'transpose' function transposes the rows and columns of its --- 'ByteString' argument. -transpose :: [ByteString] -> [ByteString] -transpose ps = P.map pack (List.transpose (P.map unpack ps)) - --- --------------------------------------------------------------------- --- Reducing 'ByteString's - --- | 'foldl', applied to a binary operator, a starting value (typically --- the left-identity of the operator), and a ByteString, reduces the --- ByteString using the binary operator, from left to right. --- -foldl :: (a -> Word8 -> a) -> a -> ByteString -> a -foldl f v (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr -> - lgo v (ptr `plusPtr` s) (ptr `plusPtr` (s+l)) - where - STRICT3(lgo) - lgo z p q | p == q = return z - | otherwise = do c <- peek p - lgo (f z c) (p `plusPtr` 1) q -{-# INLINE foldl #-} - --- | 'foldl\'' is like 'foldl', but strict in the accumulator. --- However, for ByteStrings, all left folds are strict in the accumulator. --- -foldl' :: (a -> Word8 -> a) -> a -> ByteString -> a -foldl' = foldl -{-# INLINE foldl' #-} - --- | 'foldr', applied to a binary operator, a starting value --- (typically the right-identity of the operator), and a ByteString, --- reduces the ByteString using the binary operator, from right to left. -foldr :: (Word8 -> a -> a) -> a -> ByteString -> a -foldr k v (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr -> - go v (ptr `plusPtr` (s+l-1)) (ptr `plusPtr` (s-1)) - where - STRICT3(go) - go z p q | p == q = return z - | otherwise = do c <- peek p - go (c `k` z) (p `plusPtr` (-1)) q -- tail recursive -{-# INLINE foldr #-} - --- | 'foldr\'' is like 'foldr', but strict in the accumulator. -foldr' :: (Word8 -> a -> a) -> a -> ByteString -> a -foldr' k v (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr -> - go v (ptr `plusPtr` (s+l-1)) (ptr `plusPtr` (s-1)) - where - STRICT3(go) - go z p q | p == q = return z - | otherwise = do c <- peek p - go (c `k` z) (p `plusPtr` (-1)) q -- tail recursive -{-# INLINE foldr' #-} - --- | 'foldl1' is a variant of 'foldl' that has no starting value --- argument, and thus must be applied to non-empty 'ByteStrings'. --- An exception will be thrown in the case of an empty ByteString. -foldl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 -foldl1 f ps - | null ps = errorEmptyList "foldl1" - | otherwise = foldl f (unsafeHead ps) (unsafeTail ps) -{-# INLINE foldl1 #-} - --- | 'foldl1\'' is like 'foldl1', but strict in the accumulator. --- An exception will be thrown in the case of an empty ByteString. -foldl1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 -foldl1' f ps - | null ps = errorEmptyList "foldl1'" - | otherwise = foldl' f (unsafeHead ps) (unsafeTail ps) -{-# INLINE foldl1' #-} - --- | 'foldr1' is a variant of 'foldr' that has no starting value argument, --- and thus must be applied to non-empty 'ByteString's --- An exception will be thrown in the case of an empty ByteString. -foldr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 -foldr1 f ps - | null ps = errorEmptyList "foldr1" - | otherwise = foldr f (last ps) (init ps) -{-# INLINE foldr1 #-} - --- | 'foldr1\'' is a variant of 'foldr1', but is strict in the --- accumulator. -foldr1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 -foldr1' f ps - | null ps = errorEmptyList "foldr1" - | otherwise = foldr' f (last ps) (init ps) -{-# INLINE foldr1' #-} - --- --------------------------------------------------------------------- --- Special folds - --- | /O(n)/ Concatenate a list of ByteStrings. -concat :: [ByteString] -> ByteString -concat = mconcat - --- | Map a function over a 'ByteString' and concatenate the results -concatMap :: (Word8 -> ByteString) -> ByteString -> ByteString -concatMap f = concat . foldr ((:) . f) [] - --- foldr (append . f) empty - --- | /O(n)/ Applied to a predicate and a ByteString, 'any' determines if --- any element of the 'ByteString' satisfies the predicate. -any :: (Word8 -> Bool) -> ByteString -> Bool -any _ (PS _ _ 0) = False -any f (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr -> - go (ptr `plusPtr` s) (ptr `plusPtr` (s+l)) - where - STRICT2(go) - go p q | p == q = return False - | otherwise = do c <- peek p - if f c then return True - else go (p `plusPtr` 1) q -{-# INLINE any #-} - --- todo fuse - --- | /O(n)/ Applied to a predicate and a 'ByteString', 'all' determines --- if all elements of the 'ByteString' satisfy the predicate. -all :: (Word8 -> Bool) -> ByteString -> Bool -all _ (PS _ _ 0) = True -all f (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr -> - go (ptr `plusPtr` s) (ptr `plusPtr` (s+l)) - where - STRICT2(go) - go p q | p == q = return True -- end of list - | otherwise = do c <- peek p - if f c - then go (p `plusPtr` 1) q - else return False -{-# INLINE all #-} - ------------------------------------------------------------------------- - --- | /O(n)/ 'maximum' returns the maximum value from a 'ByteString' --- This function will fuse. --- An exception will be thrown in the case of an empty ByteString. -maximum :: ByteString -> Word8 -maximum xs@(PS x s l) - | null xs = errorEmptyList "maximum" - | otherwise = inlinePerformIO $ withForeignPtr x $ \p -> - c_maximum (p `plusPtr` s) (fromIntegral l) -{-# INLINE maximum #-} - --- | /O(n)/ 'minimum' returns the minimum value from a 'ByteString' --- This function will fuse. --- An exception will be thrown in the case of an empty ByteString. -minimum :: ByteString -> Word8 -minimum xs@(PS x s l) - | null xs = errorEmptyList "minimum" - | otherwise = inlinePerformIO $ withForeignPtr x $ \p -> - c_minimum (p `plusPtr` s) (fromIntegral l) -{-# INLINE minimum #-} - ------------------------------------------------------------------------- - --- | The 'mapAccumL' function behaves like a combination of 'map' and --- 'foldl'; it applies a function to each element of a ByteString, --- passing an accumulating parameter from left to right, and returning a --- final value of this accumulator together with the new list. -mapAccumL :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) -mapAccumL f acc (PS fp o len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> do - gp <- mallocByteString len - acc' <- withForeignPtr gp $ \p -> mapAccumL_ acc 0 (a `plusPtr` o) p - return $! (acc', PS gp 0 len) - where - STRICT4(mapAccumL_) - mapAccumL_ s n p1 p2 - | n >= len = return s - | otherwise = do - x <- peekByteOff p1 n - let (s', y) = f s x - pokeByteOff p2 n y - mapAccumL_ s' (n+1) p1 p2 -{-# INLINE mapAccumL #-} - --- | The 'mapAccumR' function behaves like a combination of 'map' and --- 'foldr'; it applies a function to each element of a ByteString, --- passing an accumulating parameter from right to left, and returning a --- final value of this accumulator together with the new ByteString. -mapAccumR :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) -mapAccumR f acc (PS fp o len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> do - gp <- mallocByteString len - acc' <- withForeignPtr gp $ \p -> mapAccumR_ acc (len-1) (a `plusPtr` o) p - return $! (acc', PS gp 0 len) - where - STRICT4(mapAccumR_) - mapAccumR_ s n p q - | n < 0 = return s - | otherwise = do - x <- peekByteOff p n - let (s', y) = f s x - pokeByteOff q n y - mapAccumR_ s' (n-1) p q -{-# INLINE mapAccumR #-} - --- --------------------------------------------------------------------- --- Building ByteStrings - --- | 'scanl' is similar to 'foldl', but returns a list of successive --- reduced values from the left. This function will fuse. --- --- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] --- --- Note that --- --- > last (scanl f z xs) == foldl f z xs. --- -scanl :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString - -scanl f v (PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> - create (len+1) $ \q -> do - poke q v - scanl_ v 0 (a `plusPtr` s) (q `plusPtr` 1) - where - STRICT4(scanl_) - scanl_ z n p q - | n >= len = return () - | otherwise = do - x <- peekByteOff p n - let z' = f z x - pokeByteOff q n z' - scanl_ z' (n+1) p q -{-# INLINE scanl #-} - - -- n.b. haskell's List scan returns a list one bigger than the - -- input, so we need to snoc here to get some extra space, however, - -- it breaks map/up fusion (i.e. scanl . map no longer fuses) - --- | 'scanl1' is a variant of 'scanl' that has no starting value argument. --- This function will fuse. --- --- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] -scanl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString -scanl1 f ps - | null ps = empty - | otherwise = scanl f (unsafeHead ps) (unsafeTail ps) -{-# INLINE scanl1 #-} - --- | scanr is the right-to-left dual of scanl. -scanr :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString -scanr f v (PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> - create (len+1) $ \q -> do - poke (q `plusPtr` len) v - scanr_ v (len-1) (a `plusPtr` s) q - where - STRICT4(scanr_) - scanr_ z n p q - | n < 0 = return () - | otherwise = do - x <- peekByteOff p n - let z' = f x z - pokeByteOff q n z' - scanr_ z' (n-1) p q -{-# INLINE scanr #-} - --- | 'scanr1' is a variant of 'scanr' that has no starting value argument. -scanr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString -scanr1 f ps - | null ps = empty - | otherwise = scanr f (last ps) (init ps) -- todo, unsafe versions -{-# INLINE scanr1 #-} - --- --------------------------------------------------------------------- --- Unfolds and replicates - --- | /O(n)/ 'replicate' @n x@ is a ByteString of length @n@ with @x@ --- the value of every element. The following holds: --- --- > replicate w c = unfoldr w (\u -> Just (u,u)) c --- --- This implemenation uses @memset(3)@ -replicate :: Int -> Word8 -> ByteString -replicate w c - | w <= 0 = empty - | otherwise = unsafeCreate w $ \ptr -> - memset ptr c (fromIntegral w) >> return () - --- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' --- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a --- ByteString from a seed value. The function takes the element and --- returns 'Nothing' if it is done producing the ByteString or returns --- 'Just' @(a,b)@, in which case, @a@ is the next byte in the string, --- and @b@ is the seed value for further production. --- --- Examples: --- --- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0 --- > == pack [0, 1, 2, 3, 4, 5] --- -unfoldr :: (a -> Maybe (Word8, a)) -> a -> ByteString -unfoldr f = concat . unfoldChunk 32 64 - where unfoldChunk n n' x = - case unfoldrN n f x of - (s, Nothing) -> s : [] - (s, Just x') -> s : unfoldChunk n' (n+n') x' -{-# INLINE unfoldr #-} - --- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a ByteString from a seed --- value. However, the length of the result is limited by the first --- argument to 'unfoldrN'. This function is more efficient than 'unfoldr' --- when the maximum length of the result is known. --- --- The following equation relates 'unfoldrN' and 'unfoldr': --- --- > fst (unfoldrN n f s) == take n (unfoldr f s) --- -unfoldrN :: Int -> (a -> Maybe (Word8, a)) -> a -> (ByteString, Maybe a) -unfoldrN i f x0 - | i < 0 = (empty, Just x0) - | otherwise = unsafePerformIO $ createAndTrim' i $ \p -> go p x0 0 - where STRICT3(go) - go p x n = - case f x of - Nothing -> return (0, n, Nothing) - Just (w,x') - | n == i -> return (0, n, Just x) - | otherwise -> do poke p w - go (p `plusPtr` 1) x' (n+1) -{-# INLINE unfoldrN #-} - --- --------------------------------------------------------------------- --- Substrings - --- | /O(1)/ 'take' @n@, applied to a ByteString @xs@, returns the prefix --- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. -take :: Int -> ByteString -> ByteString -take n ps@(PS x s l) - | n <= 0 = empty - | n >= l = ps - | otherwise = PS x s n -{-# INLINE take #-} - --- | /O(1)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ --- elements, or @[]@ if @n > 'length' xs@. -drop :: Int -> ByteString -> ByteString -drop n ps@(PS x s l) - | n <= 0 = ps - | n >= l = empty - | otherwise = PS x (s+n) (l-n) -{-# INLINE drop #-} - --- | /O(1)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@. -splitAt :: Int -> ByteString -> (ByteString, ByteString) -splitAt n ps@(PS x s l) - | n <= 0 = (empty, ps) - | n >= l = (ps, empty) - | otherwise = (PS x s n, PS x (s+n) (l-n)) -{-# INLINE splitAt #-} - --- | 'takeWhile', applied to a predicate @p@ and a ByteString @xs@, --- returns the longest prefix (possibly empty) of @xs@ of elements that --- satisfy @p@. -takeWhile :: (Word8 -> Bool) -> ByteString -> ByteString -takeWhile f ps = unsafeTake (findIndexOrEnd (not . f) ps) ps -{-# INLINE takeWhile #-} - --- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@. -dropWhile :: (Word8 -> Bool) -> ByteString -> ByteString -dropWhile f ps = unsafeDrop (findIndexOrEnd (not . f) ps) ps -{-# INLINE dropWhile #-} - --- instead of findIndexOrEnd, we could use memchr here. - --- | 'break' @p@ is equivalent to @'span' ('not' . p)@. --- --- Under GHC, a rewrite rule will transform break (==) into a --- call to the specialised breakByte: --- --- > break ((==) x) = breakByte x --- > break (==x) = breakByte x --- -break :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) -break p ps = case findIndexOrEnd p ps of n -> (unsafeTake n ps, unsafeDrop n ps) -#if __GLASGOW_HASKELL__ -{-# INLINE [1] break #-} -#endif - -{-# RULES -"ByteString specialise break (x==)" forall x. - break ((==) x) = breakByte x -"ByteString specialise break (==x)" forall x. - break (==x) = breakByte x - #-} - --- INTERNAL: - --- | 'breakByte' breaks its ByteString argument at the first occurence --- of the specified byte. It is more efficient than 'break' as it is --- implemented with @memchr(3)@. I.e. --- --- > break (=='c') "abcd" == breakByte 'c' "abcd" --- -breakByte :: Word8 -> ByteString -> (ByteString, ByteString) -breakByte c p = case elemIndex c p of - Nothing -> (p,empty) - Just n -> (unsafeTake n p, unsafeDrop n p) -{-# INLINE breakByte #-} - --- | 'breakEnd' behaves like 'break' but from the end of the 'ByteString' --- --- breakEnd p == spanEnd (not.p) -breakEnd :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) -breakEnd p ps = splitAt (findFromEndUntil p ps) ps - --- | 'span' @p xs@ breaks the ByteString into two segments. It is --- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@ -span :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) -span p ps = break (not . p) ps -#if __GLASGOW_HASKELL__ -{-# INLINE [1] span #-} -#endif - --- | 'spanByte' breaks its ByteString argument at the first --- occurence of a byte other than its argument. It is more efficient --- than 'span (==)' --- --- > span (=='c') "abcd" == spanByte 'c' "abcd" --- -spanByte :: Word8 -> ByteString -> (ByteString, ByteString) -spanByte c ps@(PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> - go (p `plusPtr` s) 0 - where - STRICT2(go) - go p i | i >= l = return (ps, empty) - | otherwise = do c' <- peekByteOff p i - if c /= c' - then return (unsafeTake i ps, unsafeDrop i ps) - else go p (i+1) -{-# INLINE spanByte #-} - -{-# RULES -"ByteString specialise span (x==)" forall x. - span ((==) x) = spanByte x -"ByteString specialise span (==x)" forall x. - span (==x) = spanByte x - #-} - --- | 'spanEnd' behaves like 'span' but from the end of the 'ByteString'. --- We have --- --- > spanEnd (not.isSpace) "x y z" == ("x y ","z") --- --- and --- --- > spanEnd (not . isSpace) ps --- > == --- > let (x,y) = span (not.isSpace) (reverse ps) in (reverse y, reverse x) --- -spanEnd :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) -spanEnd p ps = splitAt (findFromEndUntil (not.p) ps) ps - --- | /O(n)/ Splits a 'ByteString' into components delimited by --- separators, where the predicate returns True for a separator element. --- The resulting components do not contain the separators. Two adjacent --- separators result in an empty component in the output. eg. --- --- > splitWith (=='a') "aabbaca" == ["","","bb","c",""] --- > splitWith (=='a') [] == [] --- -splitWith :: (Word8 -> Bool) -> ByteString -> [ByteString] - -#if defined(__GLASGOW_HASKELL__) -splitWith _pred (PS _ _ 0) = [] -splitWith pred_ (PS fp off len) = splitWith0 pred# off len fp - where pred# c# = pred_ (W8# c#) - - STRICT4(splitWith0) - splitWith0 pred' off' len' fp' = withPtr fp $ \p -> - splitLoop pred' p 0 off' len' fp' - - splitLoop :: (Word# -> Bool) - -> Ptr Word8 - -> Int -> Int -> Int - -> ForeignPtr Word8 - -> IO [ByteString] - - splitLoop pred' p idx' off' len' fp' - | idx' >= len' = return [PS fp' off' idx'] - | otherwise = do - w <- peekElemOff p (off'+idx') - if pred' (case w of W8# w# -> w#) - then return (PS fp' off' idx' : - splitWith0 pred' (off'+idx'+1) (len'-idx'-1) fp') - else splitLoop pred' p (idx'+1) off' len' fp' -{-# INLINE splitWith #-} - -#else -splitWith _ (PS _ _ 0) = [] -splitWith p ps = loop p ps - where - STRICT2(loop) - loop q qs = if null rest then [chunk] - else chunk : loop q (unsafeTail rest) - where (chunk,rest) = break q qs -#endif - --- | /O(n)/ Break a 'ByteString' into pieces separated by the byte --- argument, consuming the delimiter. I.e. --- --- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"] --- > split 'a' "aXaXaXa" == ["","X","X","X",""] --- > split 'x' "x" == ["",""] --- --- and --- --- > intercalate [c] . split c == id --- > split == splitWith . (==) --- --- As for all splitting functions in this library, this function does --- not copy the substrings, it just constructs new 'ByteStrings' that --- are slices of the original. --- -split :: Word8 -> ByteString -> [ByteString] -split _ (PS _ _ 0) = [] -split w (PS x s l) = loop 0 - where - STRICT1(loop) - loop n = - let q = inlinePerformIO $ withForeignPtr x $ \p -> - memchr (p `plusPtr` (s+n)) - w (fromIntegral (l-n)) - in if q == nullPtr - then [PS x (s+n) (l-n)] - else let i = inlinePerformIO $ withForeignPtr x $ \p -> - return (q `minusPtr` (p `plusPtr` s)) - in PS x (s+n) (i-n) : loop (i+1) - -{-# INLINE split #-} - -{- --- slower. but stays inside Haskell. -split _ (PS _ _ 0) = [] -split (W8# w#) (PS fp off len) = splitWith' off len fp - where - splitWith' off' len' fp' = withPtr fp $ \p -> - splitLoop p 0 off' len' fp' - - splitLoop :: Ptr Word8 - -> Int -> Int -> Int - -> ForeignPtr Word8 - -> IO [ByteString] - - STRICT5(splitLoop) - splitLoop p idx' off' len' fp' - | idx' >= len' = return [PS fp' off' idx'] - | otherwise = do - (W8# x#) <- peekElemOff p (off'+idx') - if word2Int# w# ==# word2Int# x# - then return (PS fp' off' idx' : - splitWith' (off'+idx'+1) (len'-idx'-1) fp') - else splitLoop p (idx'+1) off' len' fp' --} - -{- --- | Like 'splitWith', except that sequences of adjacent separators are --- treated as a single separator. eg. --- --- > tokens (=='a') "aabbaca" == ["bb","c"] --- -tokens :: (Word8 -> Bool) -> ByteString -> [ByteString] -tokens f = P.filter (not.null) . splitWith f -{-# INLINE tokens #-} --} - --- | The 'group' function takes a ByteString and returns a list of --- ByteStrings such that the concatenation of the result is equal to the --- argument. Moreover, each sublist in the result contains only equal --- elements. For example, --- --- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"] --- --- It is a special case of 'groupBy', which allows the programmer to --- supply their own equality test. It is about 40% faster than --- /groupBy (==)/ -group :: ByteString -> [ByteString] -group xs - | null xs = [] - | otherwise = ys : group zs - where - (ys, zs) = spanByte (unsafeHead xs) xs - --- | The 'groupBy' function is the non-overloaded version of 'group'. -groupBy :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString] -groupBy k xs - | null xs = [] - | otherwise = unsafeTake n xs : groupBy k (unsafeDrop n xs) - where - n = 1 + findIndexOrEnd (not . k (unsafeHead xs)) (unsafeTail xs) - --- | /O(n)/ The 'intercalate' function takes a 'ByteString' and a list of --- 'ByteString's and concatenates the list after interspersing the first --- argument between each element of the list. -intercalate :: ByteString -> [ByteString] -> ByteString -intercalate s = concat . (List.intersperse s) -{-# INLINE [1] intercalate #-} - -{-# RULES -"ByteString specialise intercalate c -> intercalateByte" forall c s1 s2 . - intercalate (singleton c) (s1 : s2 : []) = intercalateWithByte c s1 s2 - #-} - --- | /O(n)/ intercalateWithByte. An efficient way to join to two ByteStrings --- with a char. Around 4 times faster than the generalised join. --- -intercalateWithByte :: Word8 -> ByteString -> ByteString -> ByteString -intercalateWithByte c f@(PS ffp s l) g@(PS fgp t m) = unsafeCreate len $ \ptr -> - withForeignPtr ffp $ \fp -> - withForeignPtr fgp $ \gp -> do - memcpy ptr (fp `plusPtr` s) (fromIntegral l) - poke (ptr `plusPtr` l) c - memcpy (ptr `plusPtr` (l + 1)) (gp `plusPtr` t) (fromIntegral m) - where - len = length f + length g + 1 -{-# INLINE intercalateWithByte #-} - --- --------------------------------------------------------------------- --- Indexing ByteStrings - --- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0. -index :: ByteString -> Int -> Word8 -index ps n - | n < 0 = moduleError "index" ("negative index: " ++ show n) - | n >= length ps = moduleError "index" ("index too large: " ++ show n - ++ ", length = " ++ show (length ps)) - | otherwise = ps `unsafeIndex` n -{-# INLINE index #-} - --- | /O(n)/ The 'elemIndex' function returns the index of the first --- element in the given 'ByteString' which is equal to the query --- element, or 'Nothing' if there is no such element. --- This implementation uses memchr(3). -elemIndex :: Word8 -> ByteString -> Maybe Int -elemIndex c (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do - let p' = p `plusPtr` s - q <- memchr p' c (fromIntegral l) - return $! if q == nullPtr then Nothing else Just $! q `minusPtr` p' -{-# INLINE elemIndex #-} - --- | /O(n)/ The 'elemIndexEnd' function returns the last index of the --- element in the given 'ByteString' which is equal to the query --- element, or 'Nothing' if there is no such element. The following --- holds: --- --- > elemIndexEnd c xs == --- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs) --- -elemIndexEnd :: Word8 -> ByteString -> Maybe Int -elemIndexEnd ch (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> - go (p `plusPtr` s) (l-1) - where - STRICT2(go) - go p i | i < 0 = return Nothing - | otherwise = do ch' <- peekByteOff p i - if ch == ch' - then return $ Just i - else go p (i-1) -{-# INLINE elemIndexEnd #-} - --- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning --- the indices of all elements equal to the query element, in ascending order. --- This implementation uses memchr(3). -elemIndices :: Word8 -> ByteString -> [Int] -elemIndices w (PS x s l) = loop 0 - where - STRICT1(loop) - loop n = let q = inlinePerformIO $ withForeignPtr x $ \p -> - memchr (p `plusPtr` (n+s)) - w (fromIntegral (l - n)) - in if q == nullPtr - then [] - else let i = inlinePerformIO $ withForeignPtr x $ \p -> - return (q `minusPtr` (p `plusPtr` s)) - in i : loop (i+1) -{-# INLINE elemIndices #-} - -{- --- much slower -elemIndices :: Word8 -> ByteString -> [Int] -elemIndices c ps = loop 0 ps - where STRICT2(loop) - loop _ ps' | null ps' = [] - loop n ps' | c == unsafeHead ps' = n : loop (n+1) (unsafeTail ps') - | otherwise = loop (n+1) (unsafeTail ps') --} - --- | count returns the number of times its argument appears in the ByteString --- --- > count = length . elemIndices --- --- But more efficiently than using length on the intermediate list. -count :: Word8 -> ByteString -> Int -count w (PS x s m) = inlinePerformIO $ withForeignPtr x $ \p -> - fmap fromIntegral $ c_count (p `plusPtr` s) (fromIntegral m) w -{-# INLINE count #-} - -{- --- --- around 30% slower --- -count w (PS x s m) = inlinePerformIO $ withForeignPtr x $ \p -> - go (p `plusPtr` s) (fromIntegral m) 0 - where - go :: Ptr Word8 -> CSize -> Int -> IO Int - STRICT3(go) - go p l i = do - q <- memchr p w l - if q == nullPtr - then return i - else do let k = fromIntegral $ q `minusPtr` p - go (q `plusPtr` 1) (l-k-1) (i+1) --} - --- | The 'findIndex' function takes a predicate and a 'ByteString' and --- returns the index of the first element in the ByteString --- satisfying the predicate. -findIndex :: (Word8 -> Bool) -> ByteString -> Maybe Int -findIndex k (PS x s l) = inlinePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0 - where - STRICT2(go) - go ptr n | n >= l = return Nothing - | otherwise = do w <- peek ptr - if k w - then return (Just n) - else go (ptr `plusPtr` 1) (n+1) -{-# INLINE findIndex #-} - --- | The 'findIndices' function extends 'findIndex', by returning the --- indices of all elements satisfying the predicate, in ascending order. -findIndices :: (Word8 -> Bool) -> ByteString -> [Int] -findIndices p ps = loop 0 ps - where - STRICT2(loop) - loop n qs | null qs = [] - | p (unsafeHead qs) = n : loop (n+1) (unsafeTail qs) - | otherwise = loop (n+1) (unsafeTail qs) - --- --------------------------------------------------------------------- --- Searching ByteStrings - --- | /O(n)/ 'elem' is the 'ByteString' membership predicate. -elem :: Word8 -> ByteString -> Bool -elem c ps = case elemIndex c ps of Nothing -> False ; _ -> True -{-# INLINE elem #-} - --- | /O(n)/ 'notElem' is the inverse of 'elem' -notElem :: Word8 -> ByteString -> Bool -notElem c ps = not (elem c ps) -{-# INLINE notElem #-} - --- | /O(n)/ 'filter', applied to a predicate and a ByteString, --- returns a ByteString containing those characters that satisfy the --- predicate. -filter :: (Word8 -> Bool) -> ByteString -> ByteString -filter k ps@(PS x s l) - | null ps = ps - | otherwise = unsafePerformIO $ createAndTrim l $ \p -> withForeignPtr x $ \f -> do - t <- go (f `plusPtr` s) p (f `plusPtr` (s + l)) - return $! t `minusPtr` p -- actual length - where - STRICT3(go) - go f t end | f == end = return t - | otherwise = do - w <- peek f - if k w - then poke t w >> go (f `plusPtr` 1) (t `plusPtr` 1) end - else go (f `plusPtr` 1) t end -{-# INLINE filter #-} - -{- --- --- | /O(n)/ A first order equivalent of /filter . (==)/, for the common --- case of filtering a single byte. It is more efficient to use --- /filterByte/ in this case. --- --- > filterByte == filter . (==) --- --- filterByte is around 10x faster, and uses much less space, than its --- filter equivalent --- -filterByte :: Word8 -> ByteString -> ByteString -filterByte w ps = replicate (count w ps) w -{-# INLINE filterByte #-} - -{-# RULES -"ByteString specialise filter (== x)" forall x. - filter ((==) x) = filterByte x -"ByteString specialise filter (== x)" forall x. - filter (== x) = filterByte x - #-} --} - --- | /O(n)/ The 'find' function takes a predicate and a ByteString, --- and returns the first element in matching the predicate, or 'Nothing' --- if there is no such element. --- --- > find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing --- -find :: (Word8 -> Bool) -> ByteString -> Maybe Word8 -find f p = case findIndex f p of - Just n -> Just (p `unsafeIndex` n) - _ -> Nothing -{-# INLINE find #-} - -{- --- --- fuseable, but we don't want to walk the whole array. --- -find k = foldl findEFL Nothing - where findEFL a@(Just _) _ = a - findEFL _ c | k c = Just c - | otherwise = Nothing --} - --- | /O(n)/ The 'partition' function takes a predicate a ByteString and returns --- the pair of ByteStrings with elements which do and do not satisfy the --- predicate, respectively; i.e., --- --- > partition p bs == (filter p xs, filter (not . p) xs) --- -partition :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) -partition p bs = (filter p bs, filter (not . p) bs) ---TODO: use a better implementation - --- --------------------------------------------------------------------- --- Searching for substrings - --- | /O(n)/ The 'isPrefixOf' function takes two ByteStrings and returns 'True' --- iff the first is a prefix of the second. -isPrefixOf :: ByteString -> ByteString -> Bool -isPrefixOf (PS x1 s1 l1) (PS x2 s2 l2) - | l1 == 0 = True - | l2 < l1 = False - | otherwise = inlinePerformIO $ withForeignPtr x1 $ \p1 -> - withForeignPtr x2 $ \p2 -> do - i <- memcmp (p1 `plusPtr` s1) (p2 `plusPtr` s2) (fromIntegral l1) - return $! i == 0 - --- | /O(n)/ The 'isSuffixOf' function takes two ByteStrings and returns 'True' --- iff the first is a suffix of the second. --- --- The following holds: --- --- > isSuffixOf x y == reverse x `isPrefixOf` reverse y --- --- However, the real implemenation uses memcmp to compare the end of the --- string only, with no reverse required.. -isSuffixOf :: ByteString -> ByteString -> Bool -isSuffixOf (PS x1 s1 l1) (PS x2 s2 l2) - | l1 == 0 = True - | l2 < l1 = False - | otherwise = inlinePerformIO $ withForeignPtr x1 $ \p1 -> - withForeignPtr x2 $ \p2 -> do - i <- memcmp (p1 `plusPtr` s1) (p2 `plusPtr` s2 `plusPtr` (l2 - l1)) (fromIntegral l1) - return $! i == 0 - --- | Check whether one string is a substring of another. @isInfixOf --- p s@ is equivalent to @not (null (findSubstrings p s))@. -isInfixOf :: ByteString -> ByteString -> Bool -isInfixOf p s = isJust (findSubstring p s) - --- | Break a string on a substring, returning a pair of the part of the --- string prior to the match, and the rest of the string. --- --- The following relationships hold: --- --- > break (== c) l == breakSubstring (singleton c) l --- --- and: --- --- > findSubstring s l == --- > if null s then Just 0 --- > else case breakSubstring s l of --- > (x,y) | null y -> Nothing --- > | otherwise -> Just (length x) --- --- For example, to tokenise a string, dropping delimiters: --- --- > tokenise x y = h : if null t then [] else tokenise x (drop (length x) t) --- > where (h,t) = breakSubstring x y --- --- To skip to the first occurence of a string: --- --- > snd (breakSubstring x y) --- --- To take the parts of a string before a delimiter: --- --- > fst (breakSubstring x y) --- -breakSubstring :: ByteString -- ^ String to search for - -> ByteString -- ^ String to search in - -> (ByteString,ByteString) -- ^ Head and tail of string broken at substring - -breakSubstring pat src = search 0 src - where - STRICT2(search) - search n s - | null s = (src,empty) -- not found - | pat `isPrefixOf` s = (take n src,s) - | otherwise = search (n+1) (unsafeTail s) - --- | Get the first index of a substring in another string, --- or 'Nothing' if the string is not found. --- @findSubstring p s@ is equivalent to @listToMaybe (findSubstrings p s)@. -findSubstring :: ByteString -- ^ String to search for. - -> ByteString -- ^ String to seach in. - -> Maybe Int -findSubstring f i = listToMaybe (findSubstrings f i) - -{-# DEPRECATED findSubstring "findSubstring is deprecated in favour of breakSubstring." #-} - -{- -findSubstring pat str = search 0 str - where - STRICT2(search) - search n s - = let x = pat `isPrefixOf` s - in - if null s - then if x then Just n else Nothing - else if x then Just n - else search (n+1) (unsafeTail s) --} - --- | Find the indexes of all (possibly overlapping) occurances of a --- substring in a string. --- -findSubstrings :: ByteString -- ^ String to search for. - -> ByteString -- ^ String to seach in. - -> [Int] -findSubstrings pat str - | null pat = [0 .. length str] - | otherwise = search 0 str - where - STRICT2(search) - search n s - | null s = [] - | pat `isPrefixOf` s = n : search (n+1) (unsafeTail s) - | otherwise = search (n+1) (unsafeTail s) - -{-# DEPRECATED findSubstrings "findSubstrings is deprecated in favour of breakSubstring." #-} - -{- -{- This function uses the Knuth-Morris-Pratt string matching algorithm. -} - -findSubstrings pat@(PS _ _ m) str@(PS _ _ n) = search 0 0 - where - patc x = pat `unsafeIndex` x - strc x = str `unsafeIndex` x - - -- maybe we should make kmpNext a UArray before using it in search? - kmpNext = listArray (0,m) (-1:kmpNextL pat (-1)) - kmpNextL p _ | null p = [] - kmpNextL p j = let j' = next (unsafeHead p) j + 1 - ps = unsafeTail p - x = if not (null ps) && unsafeHead ps == patc j' - then kmpNext Array.! j' else j' - in x:kmpNextL ps j' - search i j = match ++ rest -- i: position in string, j: position in pattern - where match = if j == m then [(i - j)] else [] - rest = if i == n then [] else search (i+1) (next (strc i) j + 1) - next c j | j >= 0 && (j == m || c /= patc j) = next c (kmpNext Array.! j) - | otherwise = j --} - --- --------------------------------------------------------------------- --- Zipping - --- | /O(n)/ 'zip' takes two ByteStrings and returns a list of --- corresponding pairs of bytes. If one input ByteString is short, --- excess elements of the longer ByteString are discarded. This is --- equivalent to a pair of 'unpack' operations. -zip :: ByteString -> ByteString -> [(Word8,Word8)] -zip ps qs - | null ps || null qs = [] - | otherwise = (unsafeHead ps, unsafeHead qs) : zip (unsafeTail ps) (unsafeTail qs) - --- | 'zipWith' generalises 'zip' by zipping with the function given as --- the first argument, instead of a tupling function. For example, --- @'zipWith' (+)@ is applied to two ByteStrings to produce the list of --- corresponding sums. -zipWith :: (Word8 -> Word8 -> a) -> ByteString -> ByteString -> [a] -zipWith f ps qs - | null ps || null qs = [] - | otherwise = f (unsafeHead ps) (unsafeHead qs) : zipWith f (unsafeTail ps) (unsafeTail qs) -{-# NOINLINE [1] zipWith #-} - --- --- | A specialised version of zipWith for the common case of a --- simultaneous map over two bytestrings, to build a 3rd. Rewrite rules --- are used to automatically covert zipWith into zipWith' when a pack is --- performed on the result of zipWith. --- -zipWith' :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> ByteString -zipWith' f (PS fp s l) (PS fq t m) = unsafeDupablePerformIO $ - withForeignPtr fp $ \a -> - withForeignPtr fq $ \b -> - create len $ zipWith_ 0 (a `plusPtr` s) (b `plusPtr` t) - where - zipWith_ :: Int -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO () - STRICT4(zipWith_) - zipWith_ n p1 p2 r - | n >= len = return () - | otherwise = do - x <- peekByteOff p1 n - y <- peekByteOff p2 n - pokeByteOff r n (f x y) - zipWith_ (n+1) p1 p2 r - - len = min l m -{-# INLINE zipWith' #-} - -{-# RULES -"ByteString specialise zipWith" forall (f :: Word8 -> Word8 -> Word8) p q . - zipWith f p q = unpack (zipWith' f p q) - #-} - --- | /O(n)/ 'unzip' transforms a list of pairs of bytes into a pair of --- ByteStrings. Note that this performs two 'pack' operations. -unzip :: [(Word8,Word8)] -> (ByteString,ByteString) -unzip ls = (pack (P.map fst ls), pack (P.map snd ls)) -{-# INLINE unzip #-} - --- --------------------------------------------------------------------- --- Special lists - --- | /O(n)/ Return all initial segments of the given 'ByteString', shortest first. -inits :: ByteString -> [ByteString] -inits (PS x s l) = [PS x s n | n <- [0..l]] - --- | /O(n)/ Return all final segments of the given 'ByteString', longest first. -tails :: ByteString -> [ByteString] -tails p | null p = [empty] - | otherwise = p : tails (unsafeTail p) - --- less efficent spacewise: tails (PS x s l) = [PS x (s+n) (l-n) | n <- [0..l]] - --- --------------------------------------------------------------------- --- ** Ordered 'ByteString's - --- | /O(n)/ Sort a ByteString efficiently, using counting sort. -sort :: ByteString -> ByteString -sort (PS input s l) = unsafeCreate l $ \p -> allocaArray 256 $ \arr -> do - - _ <- memset (castPtr arr) 0 (256 * fromIntegral (sizeOf (undefined :: CSize))) - withForeignPtr input (\x -> countOccurrences arr (x `plusPtr` s) l) - - let STRICT2(go) - go 256 _ = return () - go i ptr = do n <- peekElemOff arr i - when (n /= 0) $ memset ptr (fromIntegral i) n >> return () - go (i + 1) (ptr `plusPtr` (fromIntegral n)) - go 0 p - where - -- | Count the number of occurrences of each byte. - -- Used by 'sort' - -- - countOccurrences :: Ptr CSize -> Ptr Word8 -> Int -> IO () - STRICT3(countOccurrences) - countOccurrences counts str len = go 0 - where - STRICT1(go) - go i | i == len = return () - | otherwise = do k <- fromIntegral `fmap` peekElemOff str i - x <- peekElemOff counts k - pokeElemOff counts k (x + 1) - go (i + 1) - -{- -sort :: ByteString -> ByteString -sort (PS x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f -> do - memcpy p (f `plusPtr` s) l - c_qsort p l -- inplace --} - --- The 'sortBy' function is the non-overloaded version of 'sort'. --- --- Try some linear sorts: radix, counting --- Or mergesort. --- --- sortBy :: (Word8 -> Word8 -> Ordering) -> ByteString -> ByteString --- sortBy f ps = undefined - --- --------------------------------------------------------------------- --- Low level constructors - --- | /O(n) construction/ Use a @ByteString@ with a function requiring a --- null-terminated @CString@. The @CString@ will be freed --- automatically. This is a memcpy(3). -useAsCString :: ByteString -> (CString -> IO a) -> IO a -useAsCString (PS fp o l) action = do - allocaBytes (l+1) $ \buf -> - withForeignPtr fp $ \p -> do - memcpy buf (p `plusPtr` o) (fromIntegral l) - pokeByteOff buf l (0::Word8) - action (castPtr buf) - --- | /O(n) construction/ Use a @ByteString@ with a function requiring a @CStringLen@. --- As for @useAsCString@ this function makes a copy of the original @ByteString@. -useAsCStringLen :: ByteString -> (CStringLen -> IO a) -> IO a -useAsCStringLen p@(PS _ _ l) f = useAsCString p $ \cstr -> f (cstr,l) - ------------------------------------------------------------------------- - --- | /O(n)./ Construct a new @ByteString@ from a @CString@. The --- resulting @ByteString@ is an immutable copy of the original --- @CString@, and is managed on the Haskell heap. The original --- @CString@ must be null terminated. -packCString :: CString -> IO ByteString -packCString cstr = do - len <- c_strlen cstr - packCStringLen (cstr, fromIntegral len) - --- | /O(n)./ Construct a new @ByteString@ from a @CStringLen@. The --- resulting @ByteString@ is an immutable copy of the original @CStringLen@. --- The @ByteString@ is a normal Haskell value and will be managed on the --- Haskell heap. -packCStringLen :: CStringLen -> IO ByteString -packCStringLen (cstr, len) | len >= 0 = create len $ \p -> - memcpy p (castPtr cstr) (fromIntegral len) -packCStringLen (_, len) = - moduleErrorIO "packCStringLen" ("negative length: " ++ show len) - ------------------------------------------------------------------------- - --- | /O(n)/ Make a copy of the 'ByteString' with its own storage. --- This is mainly useful to allow the rest of the data pointed --- to by the 'ByteString' to be garbage collected, for example --- if a large string has been read in, and only a small part of it --- is needed in the rest of the program. --- -copy :: ByteString -> ByteString -copy (PS x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f -> - memcpy p (f `plusPtr` s) (fromIntegral l) - --- --------------------------------------------------------------------- --- Line IO - --- | Read a line from stdin. -getLine :: IO ByteString -getLine = hGetLine stdin - --- | Read a line from a handle - -hGetLine :: Handle -> IO ByteString - -#if !defined(__GLASGOW_HASKELL__) - -hGetLine h = System.IO.hGetLine h >>= return . pack . P.map c2w - -#elif __GLASGOW_HASKELL__ >= 611 - -hGetLine h = - wantReadableHandle_ "Data.ByteString.hGetLine" h $ - \ h_@Handle__{haByteBuffer} -> do - flushCharReadBuffer h_ - buf <- readIORef haByteBuffer - if isEmptyBuffer buf - then fill h_ buf 0 [] - else haveBuf h_ buf 0 [] - where - - fill h_@Handle__{haByteBuffer,haDevice} buf len xss = - len `seq` do - (r,buf') <- Buffered.fillReadBuffer haDevice buf - if r == 0 - then do writeIORef haByteBuffer buf{ bufR=0, bufL=0 } - if len > 0 - then mkBigPS len xss - else ioe_EOF - else haveBuf h_ buf' len xss - - haveBuf h_@Handle__{haByteBuffer} - buf@Buffer{ bufRaw=raw, bufR=w, bufL=r } - len xss = - do - off <- findEOL r w raw - let new_len = len + off - r - xs <- mkPS raw r off - - -- if eol == True, then off is the offset of the '\n' - -- otherwise off == w and the buffer is now empty. - if off /= w - then do if (w == off + 1) - then writeIORef haByteBuffer buf{ bufL=0, bufR=0 } - else writeIORef haByteBuffer buf{ bufL = off + 1 } - mkBigPS new_len (xs:xss) - else do - fill h_ buf{ bufL=0, bufR=0 } new_len (xs:xss) - - -- find the end-of-line character, if there is one - findEOL r w raw - | r == w = return w - | otherwise = do - c <- readWord8Buf raw r - if c == fromIntegral (ord '\n') - then return r -- NB. not r+1: don't include the '\n' - else findEOL (r+1) w raw - -mkPS :: RawBuffer Word8 -> Int -> Int -> IO ByteString -mkPS buf start end = - create len $ \p -> - withRawBuffer buf $ \pbuf -> do - copyBytes p (pbuf `plusPtr` start) len - where - len = end - start - -#else --- GHC 6.10 and older, pre-Unicode IO library - -hGetLine h = wantReadableHandle "Data.ByteString.hGetLine" h $ \ handle_ -> do - case haBufferMode handle_ of - NoBuffering -> error "no buffering" - _other -> hGetLineBuffered handle_ - - where - hGetLineBuffered handle_ = do - let ref = haBuffer handle_ - buf <- readIORef ref - hGetLineBufferedLoop handle_ ref buf 0 [] - - hGetLineBufferedLoop handle_ ref - buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } len xss = - len `seq` do - off <- findEOL r w raw - let new_len = len + off - r - xs <- mkPS raw r off - - -- if eol == True, then off is the offset of the '\n' - -- otherwise off == w and the buffer is now empty. - if off /= w - then do if (w == off + 1) - then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - else writeIORef ref buf{ bufRPtr = off + 1 } - mkBigPS new_len (xs:xss) - else do - maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_) - buf{ bufWPtr=0, bufRPtr=0 } - case maybe_buf of - -- Nothing indicates we caught an EOF, and we may have a - -- partial line to return. - Nothing -> do - writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - if new_len > 0 - then mkBigPS new_len (xs:xss) - else ioe_EOF - Just new_buf -> - hGetLineBufferedLoop handle_ ref new_buf new_len (xs:xss) - - -- find the end-of-line character, if there is one - findEOL r w raw - | r == w = return w - | otherwise = do - (c,r') <- readCharFromBuffer raw r - if c == '\n' - then return r -- NB. not r': don't include the '\n' - else findEOL r' w raw - - maybeFillReadBuffer fd is_line is_stream buf = catch - (do buf' <- fillReadBuffer fd is_line is_stream buf - return (Just buf')) - (\e -> if isEOFError e then return Nothing else ioError e) - --- TODO, rewrite to use normal memcpy -mkPS :: RawBuffer -> Int -> Int -> IO ByteString -mkPS buf start end = - let len = end - start - in create len $ \p -> do - memcpy_ptr_baoff p buf (fromIntegral start) (fromIntegral len) - return () - -memcpy_ptr_baoff dst src src_off sz = memcpy dst (src+src_off) sz -#endif - -mkBigPS :: Int -> [ByteString] -> IO ByteString -mkBigPS _ [ps] = return ps -mkBigPS _ pss = return $! concat (P.reverse pss) - --- --------------------------------------------------------------------- --- Block IO - --- | Outputs a 'ByteString' to the specified 'Handle'. -hPut :: Handle -> ByteString -> IO () -hPut _ (PS _ _ 0) = return () -hPut h (PS ps s l) = withForeignPtr ps $ \p-> hPutBuf h (p `plusPtr` s) l - --- | Similar to 'hPut' except that it will never block. Instead it returns --- any tail that did not get written. This tail may be 'empty' in the case that --- the whole string was written, or the whole original string if nothing was --- written. Partial writes are also possible. --- --- Note: on Windows and with Haskell implementation other than GHC, this --- function does not work correctly; it behaves identically to 'hPut'. --- -hPutNonBlocking :: Handle -> ByteString -> IO ByteString -#if defined(__GLASGOW_HASKELL__) -hPutNonBlocking h bs@(PS ps s l) = do - bytesWritten <- withForeignPtr ps $ \p-> hPutBufNonBlocking h (p `plusPtr` s) l - return $! drop bytesWritten bs -#else -hPutNonBlocking h bs = hPut h bs >> return empty -#endif - --- | A synonym for @hPut@, for compatibility -hPutStr :: Handle -> ByteString -> IO () -hPutStr = hPut - --- | Write a ByteString to a handle, appending a newline byte -hPutStrLn :: Handle -> ByteString -> IO () -hPutStrLn h ps - | length ps < 1024 = hPut h (ps `snoc` 0x0a) - | otherwise = hPut h ps >> hPut h (singleton (0x0a)) -- don't copy - --- | Write a ByteString to stdout -putStr :: ByteString -> IO () -putStr = hPut stdout - --- | Write a ByteString to stdout, appending a newline byte -putStrLn :: ByteString -> IO () -putStrLn = hPutStrLn stdout - -{-# DEPRECATED hPutStrLn - "Use Data.ByteString.Char8.hPutStrLn instead. (Functions that rely on ASCII encodings belong in Data.ByteString.Char8)" - #-} -{-# DEPRECATED putStrLn - "Use Data.ByteString.Char8.putStrLn instead. (Functions that rely on ASCII encodings belong in Data.ByteString.Char8)" - #-} - ------------------------------------------------------------------------- --- Low level IO - --- | Read a 'ByteString' directly from the specified 'Handle'. This --- is far more efficient than reading the characters into a 'String' --- and then using 'pack'. First argument is the Handle to read from, --- and the second is the number of bytes to read. It returns the bytes --- read, up to n, or 'null' if EOF has been reached. --- --- 'hGet' is implemented in terms of 'hGetBuf'. --- --- If the handle is a pipe or socket, and the writing end --- is closed, 'hGet' will behave as if EOF was reached. --- -hGet :: Handle -> Int -> IO ByteString -hGet h i - | i > 0 = createAndTrim i $ \p -> hGetBuf h p i - | i == 0 = return empty - | otherwise = illegalBufferSize h "hGet" i - --- | hGetNonBlocking is similar to 'hGet', except that it will never block --- waiting for data to become available, instead it returns only whatever data --- is available. If there is no data available to be read, 'hGetNonBlocking' --- returns 'empty'. --- --- Note: on Windows and with Haskell implementation other than GHC, this --- function does not work correctly; it behaves identically to 'hGet'. --- -hGetNonBlocking :: Handle -> Int -> IO ByteString -#if defined(__GLASGOW_HASKELL__) -hGetNonBlocking h i - | i > 0 = createAndTrim i $ \p -> hGetBufNonBlocking h p i - | i == 0 = return empty - | otherwise = illegalBufferSize h "hGetNonBlocking" i -#else -hGetNonBlocking = hGet -#endif - --- | Like 'hGet', except that a shorter 'ByteString' may be returned --- if there are not enough bytes immediately available to satisfy the --- whole request. 'hGetSome' only blocks if there is no data --- available, and EOF has not yet been reached. --- -hGetSome :: Handle -> Int -> IO ByteString -hGetSome hh i -#if MIN_VERSION_base(4,3,0) - | i > 0 = createAndTrim i $ \p -> hGetBufSome hh p i -#else - | i > 0 = let - loop = do - s <- hGetNonBlocking hh i - if not (null s) - then return s - else do eof <- hIsEOF hh - if eof then return s - else hWaitForInput hh (-1) >> loop - -- for this to work correctly, the - -- Handle should be in binary mode - -- (see GHC ticket #3808) - in loop -#endif - | i == 0 = return empty - | otherwise = illegalBufferSize hh "hGetSome" i - -illegalBufferSize :: Handle -> String -> Int -> IO a -illegalBufferSize handle fn sz = - ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing) - --TODO: System.IO uses InvalidArgument here, but it's not exported :-( - where - msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz [] - - --- | Read entire handle contents strictly into a 'ByteString'. --- --- This function reads chunks at a time, doubling the chunksize on each --- read. The final buffer is then realloced to the appropriate size. For --- files > half of available memory, this may lead to memory exhaustion. --- Consider using 'readFile' in this case. --- --- As with 'hGet', the string representation in the file is assumed to --- be ISO-8859-1. --- --- The Handle is closed once the contents have been read, --- or if an exception is thrown. --- -hGetContents :: Handle -> IO ByteString -hGetContents h = always (hClose h) $ do -- strict, so hClose - let start_size = 1024 - p <- mallocBytes start_size - i <- hGetBuf h p start_size - if i < start_size - then do p' <- reallocBytes p i - fp <- newForeignPtr finalizerFree p' - return $! PS fp 0 i - else f p start_size - where - always = flip finally - f p s = do - let s' = 2 * s - p' <- reallocBytes p s' - i <- hGetBuf h (p' `plusPtr` s) s - if i < s - then do let i' = s + i - p'' <- reallocBytes p' i' - fp <- newForeignPtr finalizerFree p'' - return $! PS fp 0 i' - else f p' s' - --- | getContents. Read stdin strictly. Equivalent to hGetContents stdin --- The 'Handle' is closed after the contents have been read. --- -getContents :: IO ByteString -getContents = hGetContents stdin - --- | The interact function takes a function of type @ByteString -> ByteString@ --- as its argument. The entire input from the standard input device is passed --- to this function as its argument, and the resulting string is output on the --- standard output device. --- -interact :: (ByteString -> ByteString) -> IO () -interact transformer = putStr . transformer =<< getContents - --- | Read an entire file strictly into a 'ByteString'. This is far more --- efficient than reading the characters into a 'String' and then using --- 'pack'. It also may be more efficient than opening the file and --- reading it using 'hGet'. --- -readFile :: FilePath -> IO ByteString -readFile f = bracket (openBinaryFile f ReadMode) hClose - (\h -> hFileSize h >>= hGet h . fromIntegral) - --- | Write a 'ByteString' to a file. -writeFile :: FilePath -> ByteString -> IO () -writeFile f txt = bracket (openBinaryFile f WriteMode) hClose - (\h -> hPut h txt) - --- | Append a 'ByteString' to a file. -appendFile :: FilePath -> ByteString -> IO () -appendFile f txt = bracket (openBinaryFile f AppendMode) hClose - (\h -> hPut h txt) - --- --------------------------------------------------------------------- --- Internal utilities - --- | 'findIndexOrEnd' is a variant of findIndex, that returns the length --- of the string if no element is found, rather than Nothing. -findIndexOrEnd :: (Word8 -> Bool) -> ByteString -> Int -findIndexOrEnd k (PS x s l) = inlinePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0 - where - STRICT2(go) - go ptr n | n >= l = return l - | otherwise = do w <- peek ptr - if k w - then return n - else go (ptr `plusPtr` 1) (n+1) -{-# INLINE findIndexOrEnd #-} - --- | Perform an operation with a temporary ByteString -withPtr :: ForeignPtr a -> (Ptr a -> IO b) -> b -withPtr fp io = inlinePerformIO (withForeignPtr fp io) -{-# INLINE withPtr #-} - --- Common up near identical calls to `error' to reduce the number --- constant strings created when compiled: -errorEmptyList :: String -> a -errorEmptyList fun = moduleError fun "empty ByteString" -{-# NOINLINE errorEmptyList #-} - -moduleError :: String -> String -> a -moduleError fun msg = error (moduleErrorMsg fun msg) -{-# NOINLINE moduleError #-} - -moduleErrorIO :: String -> String -> IO a -moduleErrorIO fun msg = -#if MIN_VERSION_base(4,0,0) - throwIO . userError $ moduleErrorMsg fun msg -#else - throwIO . IOException . userError $ moduleErrorMsg fun msg -#endif -{-# NOINLINE moduleErrorIO #-} - -moduleErrorMsg :: String -> String -> String -moduleErrorMsg fun msg = "Data.ByteString." ++ fun ++ ':':' ':msg - --- Find from the end of the string using predicate -findFromEndUntil :: (Word8 -> Bool) -> ByteString -> Int -STRICT2(findFromEndUntil) -findFromEndUntil f ps@(PS x s l) = - if null ps then 0 - else if f (last ps) then l - else findFromEndUntil f (PS x s (l-1)) +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_HADDOCK prune #-} + +-- | +-- Module : Data.ByteString +-- Copyright : (c) The University of Glasgow 2001, +-- (c) David Roundy 2003-2005, +-- (c) Simon Marlow 2005, +-- (c) Bjorn Bringert 2006, +-- (c) Don Stewart 2005-2008, +-- (c) Duncan Coutts 2006-2013 +-- License : BSD-style +-- +-- Maintainer : dons00@gmail.com, duncan@community.haskell.org +-- Stability : stable +-- Portability : portable +-- +-- A time- and space-efficient implementation of byte vectors using +-- packed Word8 arrays, suitable for high performance use, both in terms +-- of large data quantities and high speed requirements. Byte vectors +-- are encoded as strict 'Word8' arrays of bytes, held in a 'ForeignPtr', +-- and can be passed between C and Haskell with little effort. +-- +-- The recomended way to assemble ByteStrings from smaller parts +-- is to use the builder monoid from "Data.ByteString.Builder". +-- +-- This module is intended to be imported @qualified@, to avoid name +-- clashes with "Prelude" functions. eg. +-- +-- > import qualified Data.ByteString as B +-- +-- Original GHC implementation by Bryan O\'Sullivan. +-- Rewritten to use 'Data.Array.Unboxed.UArray' by Simon Marlow. +-- Rewritten to support slices and use 'ForeignPtr' by David Roundy. +-- Rewritten again and extended by Don Stewart and Duncan Coutts. +-- + +module Data.ByteString ( + + -- * Strict @ByteString@ + ByteString, + StrictByteString, + + -- ** Heap fragmentation + -- | With GHC, the 'ByteString' representation uses /pinned memory/, + -- meaning it cannot be moved by GC. While this is ideal for use with + -- the foreign function interface and is usually efficient, this + -- representation may lead to issues with heap fragmentation and wasted + -- space if the program selectively retains a fraction of many small + -- 'ByteString's, keeping them live in memory over long durations. + -- + -- While 'ByteString' is indispensable when working with large blobs of + -- data and especially when interfacing with native C libraries, be sure + -- to also check the 'Data.ByteString.Short.ShortByteString' type. + -- As a type backed by /unpinned/ memory, @ShortByteString@ behaves + -- similarly to @Text@ (from the @text@ package) on the heap, completely + -- avoids fragmentation issues, and in many use-cases may better suit + -- your bytestring-storage needs. + + -- * Introducing and eliminating 'ByteString's + empty, + singleton, + pack, + unpack, + fromStrict, + toStrict, + fromFilePath, + toFilePath, + + -- * Basic interface + cons, + snoc, + append, + head, + uncons, + unsnoc, + last, + tail, + init, + null, + length, + + -- * Transforming ByteStrings + map, + reverse, + intersperse, + intercalate, + transpose, + + -- * Reducing 'ByteString's (folds) + foldl, + foldl', + foldl1, + foldl1', + + foldr, + foldr', + foldr1, + foldr1', + + -- ** Special folds + concat, + concatMap, + any, + all, + maximum, + minimum, + + -- * Building ByteStrings + -- ** Scans + scanl, + scanl1, + scanr, + scanr1, + + -- ** Accumulating maps + mapAccumL, + mapAccumR, + + -- ** Generating and unfolding ByteStrings + replicate, + unfoldr, + unfoldrN, + + -- * Substrings + + -- ** Breaking strings + take, + takeEnd, + drop, + dropEnd, + splitAt, + takeWhile, + takeWhileEnd, + dropWhile, + dropWhileEnd, + span, + spanEnd, + break, + breakEnd, + group, + groupBy, + inits, + tails, + initsNE, + tailsNE, + stripPrefix, + stripSuffix, + + -- ** Breaking into many substrings + split, + splitWith, + + -- * Predicates + isPrefixOf, + isSuffixOf, + isInfixOf, + + -- ** Encoding validation + isValidUtf8, + + -- ** Search for arbitrary substrings + breakSubstring, + + -- * Searching ByteStrings + + -- ** Searching by equality + elem, + notElem, + + -- ** Searching with a predicate + find, + filter, + partition, + + -- * Indexing ByteStrings + index, + indexMaybe, + (!?), + elemIndex, + elemIndices, + elemIndexEnd, + findIndex, + findIndices, + findIndexEnd, + count, + + -- * Zipping and unzipping ByteStrings + zip, + zipWith, + packZipWith, + unzip, + + -- * Ordered ByteStrings + sort, + + -- * Low level conversions + -- ** Copying ByteStrings + copy, + + -- ** Packing 'CString's and pointers + packCString, + packCStringLen, + + -- ** Using ByteStrings as 'CString's + useAsCString, + useAsCStringLen, + + -- * I\/O with 'ByteString's + + -- ** Standard input and output + getLine, + getContents, + putStr, + interact, + + -- ** Files + readFile, + writeFile, + appendFile, + + -- ** I\/O with Handles + hGetLine, + hGetContents, + hGet, + hGetSome, + hGetNonBlocking, + hPut, + hPutNonBlocking, + hPutStr, + ) where + +import qualified Prelude as P +import Prelude hiding (reverse,head,tail,last,init,Foldable(..) + ,map,lines,unlines + ,concat,any,take,drop,splitAt,takeWhile + ,dropWhile,span,break,filter + ,all,concatMap + ,scanl,scanl1,scanr,scanr1 + ,readFile,writeFile,appendFile,replicate + ,getContents,getLine,putStr,putStrLn,interact + ,zip,zipWith,unzip,notElem + ) + +import Data.Bits (finiteBitSize, shiftL, (.|.), (.&.)) + +import Data.ByteString.Internal.Type +import Data.ByteString.Lazy.Internal (fromStrict, toStrict) +import Data.ByteString.Unsafe + +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) + +import Data.Word (Word8) + +import Control.Exception (IOException, catch, finally, assert, throwIO) +import Control.Monad (when) + +import Foreign.C.String (CString, CStringLen) +import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr) +import Foreign.ForeignPtr.Unsafe(unsafeForeignPtrToPtr) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Marshal.Utils +import Foreign.Ptr +import Foreign.Storable (Storable(..)) + +-- hGetBuf and hPutBuf not available in yhc or nhc +import System.IO (stdin,stdout,hClose,hFileSize + ,hGetBuf,hPutBuf,hGetBufNonBlocking + ,hPutBufNonBlocking,withBinaryFile + ,IOMode(..),hGetBufSome) +import System.IO.Error (mkIOError, illegalOperationErrorType) + +import Data.IORef +import GHC.IO.Handle.Internals +import GHC.IO.Handle.Types +import GHC.IO.Buffer +import GHC.IO.BufferedIO as Buffered +import GHC.IO.Encoding (getFileSystemEncoding) +import GHC.Foreign (newCStringLen, peekCStringLen) +import GHC.Stack.Types (HasCallStack) +import Data.Char (ord) + +import GHC.Base (build) +import GHC.Word hiding (Word8) + +-- ----------------------------------------------------------------------------- +-- Introducing and eliminating 'ByteString's + +-- | /O(1)/ Convert a 'Word8' into a 'ByteString' +singleton :: Word8 -> ByteString +-- Taking a slice of some static data rather than allocating a new +-- buffer for each call is nice for several reasons. Since it doesn't +-- involve any side effects hidden in a 'GHC.Magic.runRW#' call, it +-- can be simplified to a constructor application. This may enable GHC +-- to perform further optimizations after inlining, and also causes a +-- fresh singleton to take only 4 words of heap space instead of 9. +-- (The buffer object itself would take up 3 words: header, size, and +-- 1 word of content. The ForeignPtrContents object used to keep the +-- buffer alive would need two more.) +singleton c = unsafeTake 1 $ unsafeDrop (fromIntegral c) allBytes +{-# INLINE singleton #-} + +-- | A static blob of all possible bytes (0x00 to 0xff) in order +allBytes :: ByteString +allBytes = unsafePackLenLiteral 0x100 + "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\xdd\xde\xdf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff"# + +-- | /O(n)/ Convert a @['Word8']@ into a 'ByteString'. +-- +-- For applications with large numbers of string literals, 'pack' can be a +-- bottleneck. In such cases, consider using 'unsafePackAddress' (GHC only). +pack :: [Word8] -> ByteString +pack = packBytes + +-- | /O(n)/ Converts a 'ByteString' to a @['Word8']@. +unpack :: ByteString -> [Word8] +unpack bs = build (unpackFoldr bs) +{-# INLINE unpack #-} + +-- +-- Have unpack fuse with good list consumers +-- +unpackFoldr :: ByteString -> (Word8 -> a -> a) -> a -> a +unpackFoldr bs k z = foldr k z bs +{-# INLINE [0] unpackFoldr #-} + +{-# RULES +"ByteString unpack-list" [1] forall bs . + unpackFoldr bs (:) [] = unpackBytes bs + #-} + +-- | Convert a 'FilePath' to a 'ByteString'. +-- +-- The 'FilePath' type is expected to use the file system encoding +-- as reported by 'GHC.IO.Encoding.getFileSystemEncoding'. This +-- encoding allows for round-tripping of arbitrary data on platforms +-- that allow arbitrary bytes in their paths. This conversion +-- function does the same thing that `System.IO.openFile` would +-- do when decoding the 'FilePath'. +-- +-- This function is in 'IO' because the file system encoding can be +-- changed. If the encoding can be assumed to be constant in your +-- use case, you may invoke this function via 'unsafePerformIO'. +-- +-- @since 0.11.2.0 +fromFilePath :: FilePath -> IO ByteString +fromFilePath path = do + enc <- getFileSystemEncoding + newCStringLen enc path >>= unsafePackMallocCStringLen + +-- | Convert a 'ByteString' to a 'FilePath'. +-- +-- This function uses the file system encoding, and resulting 'FilePath's +-- can be safely used with standard IO functions and will reference the +-- correct path in the presence of arbitrary non-UTF-8 encoded paths. +-- +-- This function is in 'IO' because the file system encoding can be +-- changed. If the encoding can be assumed to be constant in your +-- use case, you may invoke this function via 'unsafePerformIO'. +-- +-- @since 0.11.2.0 +toFilePath :: ByteString -> IO FilePath +toFilePath path = do + enc <- getFileSystemEncoding + useAsCStringLen path (peekCStringLen enc) + +-- --------------------------------------------------------------------- +-- Basic interface + +-- | /O(1)/ Test whether a ByteString is empty. +null :: ByteString -> Bool +null (BS _ l) = assert (l >= 0) $ l <= 0 +{-# INLINE null #-} + +-- --------------------------------------------------------------------- +-- | /O(1)/ 'length' returns the length of a ByteString as an 'Int'. +length :: ByteString -> Int +length (BS _ l) = assert (l >= 0) l +{-# INLINE length #-} + +------------------------------------------------------------------------ + +infixr 5 `cons` --same as list (:) +infixl 5 `snoc` + +-- | /O(n)/ 'cons' is analogous to (:) for lists, but of different +-- complexity, as it requires making a copy. +cons :: Word8 -> ByteString -> ByteString +cons c (BS x len) = unsafeCreateFp (checkedAdd "cons" len 1) $ \p -> do + pokeFp p c + memcpyFp (p `plusForeignPtr` 1) x len +{-# INLINE cons #-} + +-- | /O(n)/ Append a byte to the end of a 'ByteString' +snoc :: ByteString -> Word8 -> ByteString +snoc (BS x len) c = unsafeCreateFp (checkedAdd "snoc" len 1) $ \p -> do + memcpyFp p x len + pokeFp (p `plusForeignPtr` len) c +{-# INLINE snoc #-} + +-- | /O(1)/ Extract the first element of a ByteString, which must be non-empty. +-- An exception will be thrown in the case of an empty ByteString. +-- +-- This is a partial function, consider using 'uncons' instead. +head :: HasCallStack => ByteString -> Word8 +head (BS x l) + | l <= 0 = errorEmptyList "head" + | otherwise = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> peek p +{-# INLINE head #-} + +-- | /O(1)/ Extract the elements after the head of a ByteString, which must be non-empty. +-- An exception will be thrown in the case of an empty ByteString. +-- +-- This is a partial function, consider using 'uncons' instead. +tail :: HasCallStack => ByteString -> ByteString +tail (BS p l) + | l <= 0 = errorEmptyList "tail" + | otherwise = BS (plusForeignPtr p 1) (l-1) +{-# INLINE tail #-} + +-- | /O(1)/ Extract the 'head' and 'tail' of a ByteString, returning 'Nothing' +-- if it is empty. +uncons :: ByteString -> Maybe (Word8, ByteString) +uncons (BS x l) + | l <= 0 = Nothing + | otherwise = Just (accursedUnutterablePerformIO $ unsafeWithForeignPtr x + $ \p -> peek p, + BS (plusForeignPtr x 1) (l-1)) +{-# INLINE uncons #-} + +-- | /O(1)/ Extract the last element of a ByteString, which must be finite and non-empty. +-- An exception will be thrown in the case of an empty ByteString. +-- +-- This is a partial function, consider using 'unsnoc' instead. +last :: HasCallStack => ByteString -> Word8 +last ps@(BS x l) + | null ps = errorEmptyList "last" + | otherwise = accursedUnutterablePerformIO $ + unsafeWithForeignPtr x $ \p -> peekByteOff p (l-1) +{-# INLINE last #-} + +-- | /O(1)/ Returns all the elements of a 'ByteString' except the last one. +-- An exception will be thrown in the case of an empty ByteString. +-- +-- This is a partial function, consider using 'unsnoc' instead. +init :: HasCallStack => ByteString -> ByteString +init ps@(BS p l) + | null ps = errorEmptyList "init" + | otherwise = BS p (l-1) +{-# INLINE init #-} + +-- | /O(1)/ Extract the 'init' and 'last' of a ByteString, returning 'Nothing' +-- if it is empty. +unsnoc :: ByteString -> Maybe (ByteString, Word8) +unsnoc (BS x l) + | l <= 0 = Nothing + | otherwise = Just (BS x (l-1), + accursedUnutterablePerformIO $ + unsafeWithForeignPtr x $ \p -> peekByteOff p (l-1)) +{-# INLINE unsnoc #-} + +-- | /O(n)/ Append two ByteStrings +append :: ByteString -> ByteString -> ByteString +append = mappend +{-# INLINE append #-} + +-- --------------------------------------------------------------------- +-- Transformations + +-- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each +-- element of @xs@. +map :: (Word8 -> Word8) -> ByteString -> ByteString +map f (BS srcPtr len) = unsafeCreateFp len $ \dstPtr -> m srcPtr dstPtr + where + m !p1 !p2 = map_ 0 + where + map_ :: Int -> IO () + map_ !n + | n >= len = return () + | otherwise = do + x <- peekFpByteOff p1 n + pokeFpByteOff p2 n (f x) + map_ (n+1) +{-# INLINE map #-} + +-- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order. +reverse :: ByteString -> ByteString +reverse (BS x l) = unsafeCreateFp l $ \fp -> + unsafeWithForeignPtr fp $ \p -> + unsafeWithForeignPtr x $ \f -> + c_reverse p f (fromIntegral l) + +-- | /O(n)/ The 'intersperse' function takes a 'Word8' and a +-- 'ByteString' and \`intersperses\' that byte between the elements of +-- the 'ByteString'. It is analogous to the intersperse function on +-- Lists. +intersperse :: Word8 -> ByteString -> ByteString +intersperse c ps@(BS x l) + | length ps < 2 = ps + | otherwise = unsafeCreateFp (2*l-1) $ \fp -> + unsafeWithForeignPtr fp $ \p -> + unsafeWithForeignPtr x $ \f -> + c_intersperse p f (fromIntegral l) c + +-- | The 'transpose' function transposes the rows and columns of its +-- 'ByteString' argument. +transpose :: [ByteString] -> [ByteString] +transpose = P.map pack . List.transpose . P.map unpack + +-- --------------------------------------------------------------------- +-- Reducing 'ByteString's + +-- | 'foldl', applied to a binary operator, a starting value (typically +-- the left-identity of the operator), and a ByteString, reduces the +-- ByteString using the binary operator, from left to right. +-- +foldl :: (a -> Word8 -> a) -> a -> ByteString -> a +foldl f z = \(BS fp len) -> + let + end = unsafeForeignPtrToPtr fp `plusPtr` (-1) + -- not tail recursive; traverses array right to left + go !p | p == end = z + | otherwise = let !x = accursedUnutterablePerformIO $ do + x' <- peek p + touchForeignPtr fp + return x' + in f (go (p `plusPtr` (-1))) x + + in + go (end `plusPtr` len) +{-# INLINE foldl #-} + +{- +Note [fold inlining]: + +GHC will only inline a function marked INLINE +if it is fully saturated (meaning the number of +arguments provided at the call site is at least +equal to the number of lhs arguments). + +-} +-- | 'foldl'' is like 'foldl', but strict in the accumulator. +-- +foldl' :: (a -> Word8 -> a) -> a -> ByteString -> a +foldl' f v = \(BS fp len) -> + -- see fold inlining + let + g ptr = go v ptr + where + end = ptr `plusForeignPtr` len + -- tail recursive; traverses array left to right + go !z !p | p == end = return z + | otherwise = do x <- peekFp p + go (f z x) (p `plusForeignPtr` 1) + in + accursedUnutterablePerformIO $ g fp +{-# INLINE foldl' #-} + +-- | 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a ByteString, +-- reduces the ByteString using the binary operator, from right to left. +foldr :: (Word8 -> a -> a) -> a -> ByteString -> a +foldr k z = \(BS fp len) -> + -- see fold inlining + let + ptr = unsafeForeignPtrToPtr fp + end = ptr `plusPtr` len + -- not tail recursive; traverses array left to right + go !p | p == end = z + | otherwise = let !x = accursedUnutterablePerformIO $ do + x' <- peek p + touchForeignPtr fp + return x' + in k x (go (p `plusPtr` 1)) + in + go ptr +{-# INLINE foldr #-} + +-- | 'foldr'' is like 'foldr', but strict in the accumulator. +foldr' :: (Word8 -> a -> a) -> a -> ByteString -> a +foldr' k v = \(BS fp len) -> + -- see fold inlining + let + g ptr = go v (end `plusForeignPtr` len) + where + end = ptr `plusForeignPtr` (-1) + -- tail recursive; traverses array right to left + go !z !p | p == end = return z + | otherwise = do x <- peekFp p + go (k x z) (p `plusForeignPtr` (-1)) + in + accursedUnutterablePerformIO $ g fp + +{-# INLINE foldr' #-} + +-- | 'foldl1' is a variant of 'foldl' that has no starting value +-- argument, and thus must be applied to non-empty 'ByteString's. +-- An exception will be thrown in the case of an empty ByteString. +foldl1 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldl1 f ps = case uncons ps of + Nothing -> errorEmptyList "foldl1" + Just (h, t) -> foldl f h t +{-# INLINE foldl1 #-} + +-- | 'foldl1'' is like 'foldl1', but strict in the accumulator. +-- An exception will be thrown in the case of an empty ByteString. +foldl1' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldl1' f ps = case uncons ps of + Nothing -> errorEmptyList "foldl1'" + Just (h, t) -> foldl' f h t +{-# INLINE foldl1' #-} + +-- | 'foldr1' is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty 'ByteString's +-- An exception will be thrown in the case of an empty ByteString. +foldr1 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldr1 f ps = case unsnoc ps of + Nothing -> errorEmptyList "foldr1" + Just (b, c) -> foldr f c b +{-# INLINE foldr1 #-} + +-- | 'foldr1'' is a variant of 'foldr1', but is strict in the +-- accumulator. +foldr1' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldr1' f ps = case unsnoc ps of + Nothing -> errorEmptyList "foldr1'" + Just (b, c) -> foldr' f c b +{-# INLINE foldr1' #-} + +-- --------------------------------------------------------------------- +-- Special folds + +-- | /O(n)/ Concatenate a list of ByteStrings. +concat :: [ByteString] -> ByteString +concat = mconcat + +-- | Map a function over a 'ByteString' and concatenate the results +concatMap :: (Word8 -> ByteString) -> ByteString -> ByteString +concatMap f = concat . foldr ((:) . f) [] + +-- foldr (append . f) empty + +-- | /O(n)/ Applied to a predicate and a ByteString, 'any' determines if +-- any element of the 'ByteString' satisfies the predicate. +any :: (Word8 -> Bool) -> ByteString -> Bool +any _ (BS _ 0) = False +any f (BS x len) = accursedUnutterablePerformIO $ g x + where + g ptr = go ptr + where + end = ptr `plusForeignPtr` len + go !p | p == end = return False + | otherwise = do c <- peekFp p + if f c then return True + else go (p `plusForeignPtr` 1) +{-# INLINE [1] any #-} + +{-# RULES +"ByteString specialise any (x ==)" forall x. + any (x `eqWord8`) = anyByte x +"ByteString specialise any (== x)" forall x. + any (`eqWord8` x) = anyByte x + #-} + +-- | Is any element of 'ByteString' equal to c? +anyByte :: Word8 -> ByteString -> Bool +anyByte c (BS x l) = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> do + q <- memchr p c (fromIntegral l) + return $! q /= nullPtr +{-# INLINE anyByte #-} + +-- | /O(n)/ Applied to a predicate and a 'ByteString', 'all' determines +-- if all elements of the 'ByteString' satisfy the predicate. +all :: (Word8 -> Bool) -> ByteString -> Bool +all _ (BS _ 0) = True +all f (BS x len) = accursedUnutterablePerformIO $ g x + where + g ptr = go ptr + where + end = ptr `plusForeignPtr` len + go !p | p == end = return True -- end of list + | otherwise = do c <- peekFp p + if f c + then go (p `plusForeignPtr` 1) + else return False +{-# INLINE [1] all #-} + +{-# RULES +"ByteString specialise all (x /=)" forall x. + all (x `neWord8`) = not . anyByte x +"ByteString specialise all (/= x)" forall x. + all (`neWord8` x) = not . anyByte x + #-} + +------------------------------------------------------------------------ + +-- | /O(n)/ 'maximum' returns the maximum value from a 'ByteString' +-- An exception will be thrown in the case of an empty ByteString. +maximum :: HasCallStack => ByteString -> Word8 +maximum xs@(BS x l) + | null xs = errorEmptyList "maximum" + | otherwise = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> + c_maximum p (fromIntegral l) +{-# INLINE maximum #-} + +-- | /O(n)/ 'minimum' returns the minimum value from a 'ByteString' +-- An exception will be thrown in the case of an empty ByteString. +minimum :: HasCallStack => ByteString -> Word8 +minimum xs@(BS x l) + | null xs = errorEmptyList "minimum" + | otherwise = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> + c_minimum p (fromIntegral l) +{-# INLINE minimum #-} + +------------------------------------------------------------------------ + +-- | The 'mapAccumL' function behaves like a combination of 'map' and +-- 'foldl'; it applies a function to each element of a ByteString, +-- passing an accumulating parameter from left to right, and returning a +-- final value of this accumulator together with the new ByteString. +mapAccumL :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) +mapAccumL f acc = \(BS a len) -> unsafeDupablePerformIO $ do + -- see fold inlining + gp <- mallocByteString len + let + go src dst = mapAccumL_ acc 0 + where + mapAccumL_ !s !n + | n >= len = return s + | otherwise = do + x <- peekFpByteOff src n + let (s', y) = f s x + pokeFpByteOff dst n y + mapAccumL_ s' (n+1) + acc' <- go a gp + return (acc', BS gp len) +{-# INLINE mapAccumL #-} + +-- | The 'mapAccumR' function behaves like a combination of 'map' and +-- 'foldr'; it applies a function to each element of a ByteString, +-- passing an accumulating parameter from right to left, and returning a +-- final value of this accumulator together with the new ByteString. +mapAccumR :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) +mapAccumR f acc = \(BS a len) -> unsafeDupablePerformIO $ do + -- see fold inlining + gp <- mallocByteString len + let + go src dst = mapAccumR_ acc (len-1) + where + mapAccumR_ !s (-1) = return s + mapAccumR_ !s !n = do + x <- peekFpByteOff src n + let (s', y) = f s x + pokeFpByteOff dst n y + mapAccumR_ s' (n-1) + acc' <- go a gp + return (acc', BS gp len) +{-# INLINE mapAccumR #-} + +-- --------------------------------------------------------------------- +-- Building ByteStrings + +-- | 'scanl' is similar to 'foldl', but returns a list of successive +-- reduced values from the left. +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Note that +-- +-- > head (scanl f z xs) == z +-- > last (scanl f z xs) == foldl f z xs +-- +scanl + :: (Word8 -> Word8 -> Word8) + -- ^ accumulator -> element -> new accumulator + -> Word8 + -- ^ starting value of accumulator + -> ByteString + -- ^ input of length n + -> ByteString + -- ^ output of length n+1 +scanl f v = \(BS a len) -> unsafeCreateFp (checkedAdd "scanl" len 1) $ \q -> do + -- see fold inlining + pokeFp q v + let + go src dst = scanl_ v 0 + where + scanl_ !z !n + | n >= len = return () + | otherwise = do + x <- peekFpByteOff src n + let z' = f z x + pokeFpByteOff dst n z' + scanl_ z' (n+1) + go a (q `plusForeignPtr` 1) +{-# INLINE scanl #-} + +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument. +-- +-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] +scanl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString +scanl1 f ps = case uncons ps of + Nothing -> empty + Just (h, t) -> scanl f h t +{-# INLINE scanl1 #-} + +-- | 'scanr' is similar to 'foldr', but returns a list of successive +-- reduced values from the right. +-- +-- > scanr f z [..., x{n-1}, xn] == [..., x{n-1} `f` (xn `f` z), xn `f` z, z] +-- +-- Note that +-- +-- > head (scanr f z xs) == foldr f z xs +-- > last (scanr f z xs) == z +-- +scanr + :: (Word8 -> Word8 -> Word8) + -- ^ element -> accumulator -> new accumulator + -> Word8 + -- ^ starting value of accumulator + -> ByteString + -- ^ input of length n + -> ByteString + -- ^ output of length n+1 +scanr f v = \(BS a len) -> unsafeCreateFp (checkedAdd "scanr" len 1) $ \b -> do + -- see fold inlining + pokeFpByteOff b len v + let + go p q = scanr_ v (len-1) + where + scanr_ !z !n + | n < 0 = return () + | otherwise = do + x <- peekFpByteOff p n + let z' = f x z + pokeFpByteOff q n z' + scanr_ z' (n-1) + go a b +{-# INLINE scanr #-} + +-- | 'scanr1' is a variant of 'scanr' that has no starting value argument. +scanr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString +scanr1 f ps = case unsnoc ps of + Nothing -> empty + Just (b, c) -> scanr f c b +{-# INLINE scanr1 #-} + +-- --------------------------------------------------------------------- +-- Unfolds and replicates + +-- | /O(n)/ 'replicate' @n x@ is a ByteString of length @n@ with @x@ +-- the value of every element. The following holds: +-- +-- > replicate w c = fst (unfoldrN w (\u -> Just (u,u)) c) +replicate :: Int -> Word8 -> ByteString +replicate w c + | w <= 0 = empty + | otherwise = unsafeCreateFp w $ \fptr -> + unsafeWithForeignPtr fptr $ \ptr -> + fillBytes ptr c w +{-# INLINE replicate #-} + +-- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' +-- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a +-- ByteString from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the ByteString or returns +-- 'Just' @(a,b)@, in which case, @a@ is the next byte in the string, +-- and @b@ is the seed value for further production. +-- +-- Examples: +-- +-- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0 +-- > == pack [0, 1, 2, 3, 4, 5] +-- +unfoldr :: (a -> Maybe (Word8, a)) -> a -> ByteString +unfoldr f = concat . unfoldChunk 32 64 + where unfoldChunk n n' x = + case unfoldrN n f x of + (s, Nothing) -> [s] + (s, Just x') -> s : unfoldChunk n' (n+n') x' +{-# INLINE unfoldr #-} + +-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a ByteString from a seed +-- value. However, the length of the result is limited by the first +-- argument to 'unfoldrN'. This function is more efficient than 'unfoldr' +-- when the maximum length of the result is known. +-- +-- The following equation relates 'unfoldrN' and 'unfoldr': +-- +-- > fst (unfoldrN n f s) == take n (unfoldr f s) +-- +unfoldrN :: Int -> (a -> Maybe (Word8, a)) -> a -> (ByteString, Maybe a) +unfoldrN i f x0 + | i < 0 = (empty, Just x0) + | otherwise = unsafeDupablePerformIO $ createFpAndTrim' i $ \p -> go p x0 0 + where + go !p !x !n = go' x n + where + go' !x' !n' + | n' == i = return (0, n', Just x') + | otherwise = case f x' of + Nothing -> return (0, n', Nothing) + Just (w,x'') -> do pokeFpByteOff p n' w + go' x'' (n'+1) +{-# INLINE unfoldrN #-} + +-- --------------------------------------------------------------------- +-- Substrings + +-- | /O(1)/ 'take' @n@, applied to a ByteString @xs@, returns the prefix +-- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. +take :: Int -> ByteString -> ByteString +take n ps@(BS x l) + | n <= 0 = empty + | n >= l = ps + | otherwise = BS x n +{-# INLINE take #-} + +-- | /O(1)/ @'takeEnd' n xs@ is equivalent to @'drop' ('length' xs - n) xs@. +-- Takes @n@ elements from end of bytestring. +-- +-- >>> takeEnd 3 "abcdefg" +-- "efg" +-- >>> takeEnd 0 "abcdefg" +-- "" +-- >>> takeEnd 4 "abc" +-- "abc" +-- +-- @since 0.11.1.0 +takeEnd :: Int -> ByteString -> ByteString +takeEnd n ps@(BS x len) + | n >= len = ps + | n <= 0 = empty + | otherwise = BS (plusForeignPtr x (len - n)) n +{-# INLINE takeEnd #-} + +-- | /O(1)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ +-- elements, or 'empty' if @n > 'length' xs@. +drop :: Int -> ByteString -> ByteString +drop n ps@(BS x l) + | n <= 0 = ps + | n >= l = empty + | otherwise = BS (plusForeignPtr x n) (l-n) +{-# INLINE drop #-} + +-- | /O(1)/ @'dropEnd' n xs@ is equivalent to @'take' ('length' xs - n) xs@. +-- Drops @n@ elements from end of bytestring. +-- +-- >>> dropEnd 3 "abcdefg" +-- "abcd" +-- >>> dropEnd 0 "abcdefg" +-- "abcdefg" +-- >>> dropEnd 4 "abc" +-- "" +-- +-- @since 0.11.1.0 +dropEnd :: Int -> ByteString -> ByteString +dropEnd n ps@(BS x len) + | n <= 0 = ps + | n >= len = empty + | otherwise = BS x (len - n) +{-# INLINE dropEnd #-} + +-- | /O(1)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@. +splitAt :: Int -> ByteString -> (ByteString, ByteString) +splitAt n ps@(BS x l) + | n <= 0 = (empty, ps) + | n >= l = (ps, empty) + | otherwise = (BS x n, BS (plusForeignPtr x n) (l-n)) +{-# INLINE splitAt #-} + +-- | Similar to 'Prelude.takeWhile', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate. +takeWhile :: (Word8 -> Bool) -> ByteString -> ByteString +takeWhile f ps = unsafeTake (findIndexOrLength (not . f) ps) ps +{-# INLINE [1] takeWhile #-} + +{-# RULES +"ByteString specialise takeWhile (x /=)" forall x. + takeWhile (x `neWord8`) = fst . breakByte x +"ByteString specialise takeWhile (/= x)" forall x. + takeWhile (`neWord8` x) = fst . breakByte x +"ByteString specialise takeWhile (x ==)" forall x. + takeWhile (x `eqWord8`) = fst . spanByte x +"ByteString specialise takeWhile (== x)" forall x. + takeWhile (`eqWord8` x) = fst . spanByte x + #-} + +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate. +-- +-- @'takeWhileEnd' p@ is equivalent to @'reverse' . 'takeWhile' p . 'reverse'@. +-- +-- @since 0.10.12.0 +takeWhileEnd :: (Word8 -> Bool) -> ByteString -> ByteString +takeWhileEnd f ps = unsafeDrop (findFromEndUntil (not . f) ps) ps +{-# INLINE takeWhileEnd #-} + +-- | Similar to 'Prelude.dropWhile', +-- drops the longest (possibly empty) prefix of elements +-- satisfying the predicate and returns the remainder. +dropWhile :: (Word8 -> Bool) -> ByteString -> ByteString +dropWhile f ps = unsafeDrop (findIndexOrLength (not . f) ps) ps +{-# INLINE [1] dropWhile #-} + +{-# RULES +"ByteString specialise dropWhile (x /=)" forall x. + dropWhile (x `neWord8`) = snd . breakByte x +"ByteString specialise dropWhile (/= x)" forall x. + dropWhile (`neWord8` x) = snd . breakByte x +"ByteString specialise dropWhile (x ==)" forall x. + dropWhile (x `eqWord8`) = snd . spanByte x +"ByteString specialise dropWhile (== x)" forall x. + dropWhile (`eqWord8` x) = snd . spanByte x + #-} + +-- | Similar to 'Prelude.dropWhileEnd', +-- drops the longest (possibly empty) suffix of elements +-- satisfying the predicate and returns the remainder. +-- +-- @'dropWhileEnd' p@ is equivalent to @'reverse' . 'dropWhile' p . 'reverse'@. +-- +-- @since 0.10.12.0 +dropWhileEnd :: (Word8 -> Bool) -> ByteString -> ByteString +dropWhileEnd f ps = unsafeTake (findFromEndUntil (not . f) ps) ps +{-# INLINE dropWhileEnd #-} + +-- | Similar to 'Prelude.break', +-- returns the longest (possibly empty) prefix of elements which __do not__ +-- satisfy the predicate and the remainder of the string. +-- +-- 'break' @p@ is equivalent to @'span' (not . p)@ and to @('takeWhile' (not . p) &&& 'dropWhile' (not . p))@. +-- +-- Under GHC, a rewrite rule will transform break (==) into a +-- call to the specialised breakByte: +-- +-- > break ((==) x) = breakByte x +-- > break (==x) = breakByte x +-- +break :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +break p ps = case findIndexOrLength p ps of n -> (unsafeTake n ps, unsafeDrop n ps) +{-# INLINE [1] break #-} + +-- See bytestring #70 +{-# RULES +"ByteString specialise break (x ==)" forall x. + break (x `eqWord8`) = breakByte x +"ByteString specialise break (== x)" forall x. + break (`eqWord8` x) = breakByte x + #-} + +-- INTERNAL: + +-- | 'breakByte' breaks its ByteString argument at the first occurrence +-- of the specified byte. It is more efficient than 'break' as it is +-- implemented with @memchr(3)@. I.e. +-- +-- > break (==99) "abcd" == breakByte 99 "abcd" -- fromEnum 'c' == 99 +-- +breakByte :: Word8 -> ByteString -> (ByteString, ByteString) +breakByte c p = case elemIndex c p of + Nothing -> (p,empty) + Just n -> (unsafeTake n p, unsafeDrop n p) +{-# INLINE breakByte #-} + +-- | Returns the longest (possibly empty) suffix of elements which __do not__ +-- satisfy the predicate and the remainder of the string. +-- +-- 'breakEnd' @p@ is equivalent to @'spanEnd' (not . p)@ and to @('dropWhileEnd' (not . p) &&& 'takeWhileEnd' (not . p))@. +-- +breakEnd :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +breakEnd p ps = splitAt (findFromEndUntil p ps) ps + +-- | Similar to 'Prelude.span', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate and the remainder of the string. +-- +-- 'span' @p@ is equivalent to @'break' (not . p)@ and to @('takeWhile' p &&& 'dropWhile' p)@. +-- +span :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +span p = break (not . p) +{-# INLINE [1] span #-} + +-- | 'spanByte' breaks its ByteString argument at the first +-- occurrence of a byte other than its argument. It is more efficient +-- than 'span (==)' +-- +-- > span (==99) "abcd" == spanByte 99 "abcd" -- fromEnum 'c' == 99 +-- +spanByte :: Word8 -> ByteString -> (ByteString, ByteString) +spanByte c ps@(BS x l) = + accursedUnutterablePerformIO $ unsafeWithForeignPtr x g + where + g p = go 0 + where + go !i | i >= l = return (ps, empty) + | otherwise = do c' <- peekByteOff p i + if c /= c' + then return (unsafeTake i ps, unsafeDrop i ps) + else go (i+1) +{-# INLINE spanByte #-} + +-- See bytestring #70 +{-# RULES +"ByteString specialise span (x ==)" forall x. + span (x `eqWord8`) = spanByte x +"ByteString specialise span (== x)" forall x. + span (`eqWord8` x) = spanByte x + #-} + +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate and the remainder of the string. +-- +-- 'spanEnd' @p@ is equivalent to @'breakEnd' (not . p)@ and to @('dropWhileEnd' p &&& 'takeWhileEnd' p)@. +-- +-- We have +-- +-- > spanEnd (not . isSpace) "x y z" == ("x y ", "z") +-- +-- and +-- +-- > spanEnd (not . isSpace) ps +-- > == +-- > let (x, y) = span (not . isSpace) (reverse ps) in (reverse y, reverse x) +-- +spanEnd :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +spanEnd p ps = splitAt (findFromEndUntil (not.p) ps) ps + +-- | /O(n)/ Splits a 'ByteString' into components delimited by +-- separators, where the predicate returns True for a separator element. +-- The resulting components do not contain the separators. Two adjacent +-- separators result in an empty component in the output. eg. +-- +-- > splitWith (==97) "aabbaca" == ["","","bb","c",""] -- fromEnum 'a' == 97 +-- > splitWith undefined "" == [] -- and not [""] +-- +splitWith :: (Word8 -> Bool) -> ByteString -> [ByteString] +splitWith _ (BS _ 0) = [] +splitWith predicate (BS fp len) = splitWith0 0 len fp + where splitWith0 !off' !len' !fp' = + accursedUnutterablePerformIO $ + splitLoop fp 0 off' len' fp' + + splitLoop :: ForeignPtr Word8 + -> Int -> Int -> Int + -> ForeignPtr Word8 + -> IO [ByteString] + splitLoop p idx2 off' len' fp' = go idx2 + where + go idx' + | idx' >= len' = return [BS (plusForeignPtr fp' off') idx'] + | otherwise = do + w <- peekFpByteOff p (off'+idx') + if predicate w + then return (BS (plusForeignPtr fp' off') idx' : + splitWith0 (off'+idx'+1) (len'-idx'-1) fp') + else go (idx'+1) +{-# INLINE splitWith #-} + +-- | /O(n)/ Break a 'ByteString' into pieces separated by the byte +-- argument, consuming the delimiter. I.e. +-- +-- > split 10 "a\nb\nd\ne" == ["a","b","d","e"] -- fromEnum '\n' == 10 +-- > split 97 "aXaXaXa" == ["","X","X","X",""] -- fromEnum 'a' == 97 +-- > split 120 "x" == ["",""] -- fromEnum 'x' == 120 +-- > split undefined "" == [] -- and not [""] +-- +-- and +-- +-- > intercalate [c] . split c == id +-- > split == splitWith . (==) +-- +-- As for all splitting functions in this library, this function does +-- not copy the substrings, it just constructs new 'ByteString's that +-- are slices of the original. +-- +split :: Word8 -> ByteString -> [ByteString] +split _ (BS _ 0) = [] +split w (BS x l) = loop 0 + where + loop !n = + let q = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> + memchr (p `plusPtr` n) + w (fromIntegral (l-n)) + in if q == nullPtr + then [BS (plusForeignPtr x n) (l-n)] + else let i = q `minusPtr` unsafeForeignPtrToPtr x + in BS (plusForeignPtr x n) (i-n) : loop (i+1) + +{-# INLINE split #-} + + +-- | The 'group' function takes a ByteString and returns a list of +-- ByteStrings such that the concatenation of the result is equal to the +-- argument. Moreover, each string in the result contains only equal +-- elements. For example, +-- +-- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"] +-- +-- It is a special case of 'groupBy', which allows the programmer to +-- supply their own equality test. It is about 40% faster than +-- /groupBy (==)/ +group :: ByteString -> [ByteString] +group xs = case uncons xs of + Nothing -> [] + Just (h, _) -> ys : group zs + where + (ys, zs) = spanByte h xs + +-- | The 'groupBy' function is the non-overloaded version of 'group'. +groupBy :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString] +groupBy k xs = case uncons xs of + Nothing -> [] + Just (h, t) -> unsafeTake n xs : groupBy k (unsafeDrop n xs) + where + n = 1 + findIndexOrLength (not . k h) t + +-- | /O(n)/ The 'intercalate' function takes a 'ByteString' and a list of +-- 'ByteString's and concatenates the list after interspersing the first +-- argument between each element of the list. +intercalate :: ByteString -> [ByteString] -> ByteString +intercalate _ [] = mempty +intercalate _ [x] = x -- This branch exists for laziness, not speed +intercalate (BS sepPtr sepLen) (BS hPtr hLen : t) = + unsafeCreateFp totalLen $ \dstPtr0 -> do + memcpyFp dstPtr0 hPtr hLen + let go _ [] = pure () + go dstPtr (BS chunkPtr chunkLen : chunks) = do + memcpyFp dstPtr sepPtr sepLen + let destPtr' = dstPtr `plusForeignPtr` sepLen + memcpyFp destPtr' chunkPtr chunkLen + go (destPtr' `plusForeignPtr` chunkLen) chunks + go (dstPtr0 `plusForeignPtr` hLen) t + where + totalLen = List.foldl' (\acc chunk -> acc +! sepLen +! length chunk) hLen t + (+!) = checkedAdd "intercalate" +{-# INLINABLE intercalate #-} + +-- --------------------------------------------------------------------- +-- Indexing ByteStrings + +-- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0. +-- +-- This is a partial function, consider using 'indexMaybe' instead. +index :: HasCallStack => ByteString -> Int -> Word8 +index ps n + | n < 0 = moduleError "index" ("negative index: " ++ show n) + | n >= length ps = moduleError "index" ("index too large: " ++ show n + ++ ", length = " ++ show (length ps)) + | otherwise = ps `unsafeIndex` n +{-# INLINE index #-} + +-- | /O(1)/ 'ByteString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 0.11.0.0 +indexMaybe :: ByteString -> Int -> Maybe Word8 +indexMaybe ps n + | n < 0 = Nothing + | n >= length ps = Nothing + | otherwise = Just $! ps `unsafeIndex` n +{-# INLINE indexMaybe #-} + +-- | /O(1)/ 'ByteString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 0.11.0.0 +(!?) :: ByteString -> Int -> Maybe Word8 +(!?) = indexMaybe +{-# INLINE (!?) #-} + +-- | /O(n)/ The 'elemIndex' function returns the index of the first +-- element in the given 'ByteString' which is equal to the query +-- element, or 'Nothing' if there is no such element. +-- This implementation uses memchr(3). +elemIndex :: Word8 -> ByteString -> Maybe Int +elemIndex c (BS x l) = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> do + q <- memchr p c (fromIntegral l) + return $! if q == nullPtr then Nothing else Just $! q `minusPtr` p +{-# INLINE elemIndex #-} + +-- | /O(n)/ The 'elemIndexEnd' function returns the last index of the +-- element in the given 'ByteString' which is equal to the query +-- element, or 'Nothing' if there is no such element. The following +-- holds: +-- +-- > elemIndexEnd c xs = case elemIndex c (reverse xs) of +-- > Nothing -> Nothing +-- > Just i -> Just (length xs - 1 - i) +-- +elemIndexEnd :: Word8 -> ByteString -> Maybe Int +elemIndexEnd = findIndexEnd . (==) +{-# INLINE elemIndexEnd #-} + +-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning +-- the indices of all elements equal to the query element, in ascending order. +-- This implementation uses memchr(3). +elemIndices :: Word8 -> ByteString -> [Int] +elemIndices w (BS x l) = loop 0 + where + loop !n = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> do + q <- memchr (p `plusPtr` n) w (fromIntegral (l - n)) + if q == nullPtr + then return [] + else let !i = q `minusPtr` p + in return $ i : loop (i + 1) +{-# INLINE elemIndices #-} + +-- | count returns the number of times its argument appears in the ByteString +-- +-- > count = length . elemIndices +-- +-- But more efficiently than using length on the intermediate list. +count :: Word8 -> ByteString -> Int +count w (BS x m) = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> + fromIntegral <$> c_count p (fromIntegral m) w +{-# INLINE count #-} + +-- | /O(n)/ The 'findIndex' function takes a predicate and a 'ByteString' and +-- returns the index of the first element in the ByteString +-- satisfying the predicate. +findIndex :: (Word8 -> Bool) -> ByteString -> Maybe Int +findIndex k (BS x l) = accursedUnutterablePerformIO $ g x + where + g !ptr = go 0 + where + go !n | n >= l = return Nothing + | otherwise = do w <- peekFp $ ptr `plusForeignPtr` n + if k w + then return (Just n) + else go (n+1) +{-# INLINE [1] findIndex #-} + +-- | /O(n)/ The 'findIndexEnd' function takes a predicate and a 'ByteString' and +-- returns the index of the last element in the ByteString +-- satisfying the predicate. +-- +-- @since 0.10.12.0 +findIndexEnd :: (Word8 -> Bool) -> ByteString -> Maybe Int +findIndexEnd k (BS x l) = accursedUnutterablePerformIO $ g x + where + g !ptr = go (l-1) + where + go !n | n < 0 = return Nothing + | otherwise = do w <- peekFpByteOff ptr n + if k w + then return (Just n) + else go (n-1) +{-# INLINE findIndexEnd #-} + +-- | /O(n)/ The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending order. +findIndices :: (Word8 -> Bool) -> ByteString -> [Int] +findIndices p = loop 0 + where + loop !n !qs = case findIndex p qs of + Just !i -> + let !j = n+i + in j : loop (j+1) (unsafeDrop (i+1) qs) + Nothing -> [] +{-# INLINE [1] findIndices #-} + + +{-# RULES +"ByteString specialise findIndex (x ==)" forall x. findIndex (x`eqWord8`) = elemIndex x +"ByteString specialise findIndex (== x)" forall x. findIndex (`eqWord8`x) = elemIndex x +"ByteString specialise findIndices (x ==)" forall x. findIndices (x`eqWord8`) = elemIndices x +"ByteString specialise findIndices (== x)" forall x. findIndices (`eqWord8`x) = elemIndices x + #-} + +-- --------------------------------------------------------------------- +-- Searching ByteStrings + +-- | /O(n)/ 'elem' is the 'ByteString' membership predicate. +elem :: Word8 -> ByteString -> Bool +elem c ps = case elemIndex c ps of Nothing -> False ; _ -> True +{-# INLINE elem #-} + +-- | /O(n)/ 'notElem' is the inverse of 'elem' +notElem :: Word8 -> ByteString -> Bool +notElem c ps = not (c `elem` ps) +{-# INLINE notElem #-} + +-- | /O(n)/ 'filter', applied to a predicate and a ByteString, +-- returns a ByteString containing those characters that satisfy the +-- predicate. +filter :: (Word8 -> Bool) -> ByteString -> ByteString +filter k = \ps@(BS pIn l) -> + -- see fold inlining. + if null ps + then ps + else + unsafeDupablePerformIO $ createFpAndTrim l $ \pOut -> do + let + go' pf pt = go pf pt + where + end = pf `plusForeignPtr` l + go !f !t | f == end = return t + | otherwise = do + w <- peekFp f + if k w + then pokeFp t w + >> go (f `plusForeignPtr` 1) (t `plusForeignPtr` 1) + else go (f `plusForeignPtr` 1) t + t <- go' pIn pOut + return $! t `minusForeignPtr` pOut -- actual length +{-# INLINE filter #-} + +{- +-- +-- | /O(n)/ A first order equivalent of /filter . (==)/, for the common +-- case of filtering a single byte. It is more efficient to use +-- /filterByte/ in this case. +-- +-- > filterByte == filter . (==) +-- +-- filterByte is around 10x faster, and uses much less space, than its +-- filter equivalent +-- +filterByte :: Word8 -> ByteString -> ByteString +filterByte w ps = replicate (count w ps) w +{-# INLINE filterByte #-} + +{-# RULES +"ByteString specialise filter (== x)" forall x. + filter ((==) x) = filterByte x +"ByteString specialise filter (== x)" forall x. + filter (== x) = filterByte x + #-} +-} + +-- | /O(n)/ The 'find' function takes a predicate and a ByteString, +-- and returns the first element in matching the predicate, or 'Nothing' +-- if there is no such element. +-- +-- > find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing +-- +find :: (Word8 -> Bool) -> ByteString -> Maybe Word8 +find f p = case findIndex f p of + Just n -> Just (p `unsafeIndex` n) + _ -> Nothing +{-# INLINE find #-} + +-- | /O(n)/ The 'partition' function takes a predicate a ByteString and returns +-- the pair of ByteStrings with elements which do and do not satisfy the +-- predicate, respectively; i.e., +-- +-- > partition p bs == (filter p xs, filter (not . p) xs) +-- +partition :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +partition f s = unsafeDupablePerformIO $ + do p <- mallocByteString len + let end = p `plusForeignPtr` (len - 1) + mid <- sep 0 p end + rev mid end + let i = mid `minusForeignPtr` p + return (BS p i, + BS (p `plusForeignPtr` i) (len - i)) + where + len = length s + incr = (`plusForeignPtr` 1) + decr = (`plusForeignPtr` (-1)) + + sep !i !p1 !p2 + | i == len = return p1 + | f w = do pokeFp p1 w + sep (i + 1) (incr p1) p2 + | otherwise = do pokeFp p2 w + sep (i + 1) p1 (decr p2) + where + w = s `unsafeIndex` i + + rev !p1 !p2 -- fixme: surely there are faster ways to do this + | p1 >= p2 = return () + | otherwise = do a <- peekFp p1 + b <- peekFp p2 + pokeFp p1 b + pokeFp p2 a + rev (incr p1) (decr p2) + +-- -------------------------------------------------------------------- +-- Sarching for substrings + +-- |/O(n)/ The 'isPrefixOf' function takes two ByteStrings and returns 'True' +-- if the first is a prefix of the second. +isPrefixOf :: ByteString -> ByteString -> Bool +isPrefixOf (BS x1 l1) (BS x2 l2) + | l1 == 0 = True + | l2 < l1 = False + | otherwise = accursedUnutterablePerformIO $ unsafeWithForeignPtr x1 $ \p1 -> + unsafeWithForeignPtr x2 $ \p2 -> do + i <- memcmp p1 p2 (fromIntegral l1) + return $! i == 0 + +-- | /O(n)/ The 'stripPrefix' function takes two ByteStrings and returns 'Just' +-- the remainder of the second iff the first is its prefix, and otherwise +-- 'Nothing'. +-- +-- @since 0.10.8.0 +stripPrefix :: ByteString -> ByteString -> Maybe ByteString +stripPrefix bs1@(BS _ l1) bs2 + | bs1 `isPrefixOf` bs2 = Just (unsafeDrop l1 bs2) + | otherwise = Nothing + +-- | /O(n)/ The 'isSuffixOf' function takes two ByteStrings and returns 'True' +-- iff the first is a suffix of the second. +-- +-- The following holds: +-- +-- > isSuffixOf x y == reverse x `isPrefixOf` reverse y +-- +-- However, the real implementation uses memcmp to compare the end of the +-- string only, with no reverse required.. +isSuffixOf :: ByteString -> ByteString -> Bool +isSuffixOf (BS x1 l1) (BS x2 l2) + | l1 == 0 = True + | l2 < l1 = False + | otherwise = accursedUnutterablePerformIO $ unsafeWithForeignPtr x1 $ \p1 -> + unsafeWithForeignPtr x2 $ \p2 -> do + i <- memcmp p1 (p2 `plusPtr` (l2 - l1)) (fromIntegral l1) + return $! i == 0 + +-- | /O(n)/ The 'stripSuffix' function takes two ByteStrings and returns 'Just' +-- the remainder of the second iff the first is its suffix, and otherwise +-- 'Nothing'. +stripSuffix :: ByteString -> ByteString -> Maybe ByteString +stripSuffix bs1@(BS _ l1) bs2@(BS _ l2) + | bs1 `isSuffixOf` bs2 = Just (unsafeTake (l2 - l1) bs2) + | otherwise = Nothing + +-- | Check whether one string is a substring of another. +isInfixOf :: ByteString -> ByteString -> Bool +isInfixOf p s = null p || not (null $ snd $ breakSubstring p s) + +-- | /O(n)/ Check whether a 'ByteString' represents valid UTF-8. +-- +-- @since 0.11.2.0 +isValidUtf8 :: ByteString -> Bool +isValidUtf8 (BS ptr len) = accursedUnutterablePerformIO $ unsafeWithForeignPtr ptr $ \p -> do + -- Use a safe FFI call for large inputs to avoid GC synchronization pauses + -- in multithreaded contexts. + -- This specific limit was chosen based on results of a simple benchmark, see: + -- https://github.com/haskell/bytestring/issues/451#issuecomment-991879338 + -- When changing this function, also consider changing the related function: + -- Data.ByteString.Short.Internal.isValidUtf8 + i <- if len < 1000000 + then cIsValidUtf8 p (fromIntegral len) + else cIsValidUtf8Safe p (fromIntegral len) + pure $ i /= 0 + +-- | Break a string on a substring, returning a pair of the part of the +-- string prior to the match, and the rest of the string. +-- +-- The following relationships hold: +-- +-- > break (== c) l == breakSubstring (singleton c) l +-- +-- For example, to tokenise a string, dropping delimiters: +-- +-- > tokenise x y = h : if null t then [] else tokenise x (drop (length x) t) +-- > where (h,t) = breakSubstring x y +-- +-- To skip to the first occurrence of a string: +-- +-- > snd (breakSubstring x y) +-- +-- To take the parts of a string before a delimiter: +-- +-- > fst (breakSubstring x y) +-- +-- Note that calling `breakSubstring x` does some preprocessing work, so +-- you should avoid unnecessarily duplicating breakSubstring calls with the same +-- pattern. +-- +breakSubstring :: ByteString -- ^ String to search for + -> ByteString -- ^ String to search in + -> (ByteString,ByteString) -- ^ Head and tail of string broken at substring +breakSubstring pat = + case lp of + 0 -> (empty,) + 1 -> breakByte (unsafeHead pat) + _ -> if lp * 8 <= finiteBitSize (0 :: Word) + then shift + else karpRabin + where + unsafeSplitAt i s = (unsafeTake i s, unsafeDrop i s) + lp = length pat + karpRabin :: ByteString -> (ByteString, ByteString) + karpRabin src + | length src < lp = (src,empty) + | otherwise = search (rollingHash $ unsafeTake lp src) lp + where + k = 2891336453 :: Word32 + rollingHash = foldl' (\h b -> h * k + fromIntegral b) 0 + hp = rollingHash pat + m = k ^ lp + get = fromIntegral . unsafeIndex src + search !hs !i + | hp == hs && pat == unsafeTake lp b = u + | length src <= i = (src,empty) -- not found + | otherwise = search hs' (i + 1) + where + u@(_, b) = unsafeSplitAt (i - lp) src + hs' = hs * k + + get i - + m * get (i - lp) + {-# INLINE karpRabin #-} + + shift :: ByteString -> (ByteString, ByteString) + shift !src + | length src < lp = (src,empty) + | otherwise = search (intoWord $ unsafeTake lp src) lp + where + intoWord :: ByteString -> Word + intoWord = foldl' (\w b -> (w `shiftL` 8) .|. fromIntegral b) 0 + wp = intoWord pat + mask = (1 `shiftL` (8 * lp)) - 1 + search !w !i + | w == wp = unsafeSplitAt (i - lp) src + | length src <= i = (src, empty) + | otherwise = search w' (i + 1) + where + b = fromIntegral (unsafeIndex src i) + w' = mask .&. ((w `shiftL` 8) .|. b) + {-# INLINE shift #-} + +-- --------------------------------------------------------------------- +-- Zipping + +-- | /O(n)/ 'zip' takes two ByteStrings and returns a list of +-- corresponding pairs of bytes. If one input ByteString is short, +-- excess elements of the longer ByteString are discarded. This is +-- equivalent to a pair of 'unpack' operations. +zip :: ByteString -> ByteString -> [(Word8,Word8)] +zip ps qs = case uncons ps of + Nothing -> [] + Just (psH, psT) -> case uncons qs of + Nothing -> [] + Just (qsH, qsT) -> (psH, qsH) : zip psT qsT + +-- | 'zipWith' generalises 'zip' by zipping with the function given as +-- the first argument, instead of a tupling function. For example, +-- @'zipWith' (+)@ is applied to two ByteStrings to produce the list of +-- corresponding sums. +zipWith :: (Word8 -> Word8 -> a) -> ByteString -> ByteString -> [a] +zipWith f ps qs = case uncons ps of + Nothing -> [] + Just (psH, psT) -> case uncons qs of + Nothing -> [] + Just (qsH, qsT) -> f psH qsH : zipWith f psT qsT +{-# NOINLINE [1] zipWith #-} + +-- | A specialised version of `zipWith` for the common case of a +-- simultaneous map over two ByteStrings, to build a 3rd. +-- +-- @since 0.11.1.0 +packZipWith :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> ByteString +packZipWith f (BS a l) (BS b m) = unsafeDupablePerformIO $ + createFp len $ go a b + where + go p1 p2 = zipWith_ 0 + where + zipWith_ :: Int -> ForeignPtr Word8 -> IO () + zipWith_ !n !r + | n >= len = return () + | otherwise = do + x <- peekFpByteOff p1 n + y <- peekFpByteOff p2 n + pokeFpByteOff r n (f x y) + zipWith_ (n+1) r + + len = min l m +{-# INLINE packZipWith #-} + +-- | /O(n)/ 'unzip' transforms a list of pairs of bytes into a pair of +-- ByteStrings. Note that this performs two 'pack' operations. +unzip :: [(Word8,Word8)] -> (ByteString,ByteString) +unzip ls = (pack (P.map fst ls), pack (P.map snd ls)) +{-# INLINE unzip #-} + +-- --------------------------------------------------------------------- +-- Special lists + +-- | /O(n)/ Returns all initial segments of the given 'ByteString', shortest first. +inits :: ByteString -> [ByteString] +-- see Note [Avoid NonEmpty combinators] +inits bs = NE.toList $! initsNE bs + +-- | /O(n)/ Returns all initial segments of the given 'ByteString', shortest first. +-- +-- @since 0.11.4.0 +initsNE :: ByteString -> NonEmpty ByteString +-- see Note [Avoid NonEmpty combinators] +initsNE (BS x len) = empty :| [BS x n | n <- [1..len]] + +-- | /O(n)/ Returns all final segments of the given 'ByteString', longest first. +tails :: ByteString -> [ByteString] +-- see Note [Avoid NonEmpty combinators] +tails bs = NE.toList $! tailsNE bs + +-- | /O(n)/ Returns all final segments of the given 'ByteString', longest first. +-- +-- @since 0.11.4.0 +tailsNE :: ByteString -> NonEmpty ByteString +-- see Note [Avoid NonEmpty combinators] +tailsNE p | null p = empty :| [] + | otherwise = p :| tails (unsafeTail p) + +-- less efficent spacewise: tails (BS x l) = [BS (plusForeignPtr x n) (l-n) | n <- [0..l]] + +{- +Note [Avoid NonEmpty combinators] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +As of base-4.18, most of the NonEmpty API is surprisingly lazy. +Using it without forcing the arguments yourself is just begging GHC +to make your code waste time allocating useless selector thunks. +This may change in the future. See also this CLC issue: + https://github.com/haskell/core-libraries-committee/issues/107 +But until then, "refactor" with care! + +(Even for uses of NonEmpty near lazy ByteStrings, we don't want +the extra laziness of the NonEmpty API.) +-} + + + +-- --------------------------------------------------------------------- +-- ** Ordered 'ByteString's + +-- | /O(n)/ Sort a ByteString efficiently, using counting sort. +sort :: ByteString -> ByteString +sort (BS input l) + -- qsort outperforms counting sort for small arrays + | l <= 20 = unsafeCreateFp l $ \destFP -> do + memcpyFp destFP input l + unsafeWithForeignPtr destFP $ \dest -> c_sort dest (fromIntegral l) + | otherwise = unsafeCreateFp l $ \p -> allocaArray 256 $ \arr -> do + + fillBytes (castPtr arr) 0 (256 * sizeOf (undefined :: Int)) + unsafeWithForeignPtr input (\x -> countOccurrences arr x l) + + let go 256 !_ = return () + go i !ptr = do n <- peekElemOff arr i + when (n /= 0) $ + fillBytes ptr (fromIntegral @Int @Word8 i) n + go (i + 1) (ptr `plusPtr` fromIntegral n) + unsafeWithForeignPtr p (go 0) + where + -- Count the number of occurrences of each byte. + countOccurrences :: Ptr Int -> Ptr Word8 -> Int -> IO () + countOccurrences !counts !str !len = go 0 + where + go !i | i == len = return () + | otherwise = do k <- fromIntegral `fmap` peekElemOff str i + x <- peekElemOff counts k + pokeElemOff counts k (x + 1) + go (i + 1) + + +-- --------------------------------------------------------------------- +-- Low level constructors + +-- | /O(n) construction/ Use a @ByteString@ with a function requiring a +-- null-terminated @CString@. The @CString@ is a copy and will be freed +-- automatically; it must not be stored or used after the +-- subcomputation finishes. +useAsCString :: ByteString -> (CString -> IO a) -> IO a +useAsCString (BS fp l) action = + allocaBytes (l+1) $ \buf -> do + unsafeWithForeignPtr fp $ \p -> copyBytes buf p l + pokeByteOff buf l (0::Word8) + action (castPtr buf) + +-- | /O(n) construction/ Use a @ByteString@ with a function requiring a 'CStringLen'. +-- As for 'useAsCString' this function makes a copy of the original @ByteString@. +-- It must not be stored or used after the subcomputation finishes. +-- +-- Beware that this function is not required to add a terminating @\NUL@ byte at the end of the 'CStringLen' it provides. +-- If you need to construct a pointer to a null-terminated sequence, use 'useAsCString' +-- (and measure length independently if desired). +useAsCStringLen :: ByteString -> (CStringLen -> IO a) -> IO a +useAsCStringLen p@(BS _ l) f = useAsCString p $ \cstr -> f (cstr,l) + +------------------------------------------------------------------------ + +-- | /O(n)./ Construct a new @ByteString@ from a @CString@. The +-- resulting @ByteString@ is an immutable copy of the original +-- @CString@, and is managed on the Haskell heap. The original +-- @CString@ must be null terminated. +packCString :: CString -> IO ByteString +packCString cstr = do + len <- c_strlen cstr + packCStringLen (cstr, fromIntegral len) + +-- | /O(n)./ Construct a new @ByteString@ from a @CStringLen@. The +-- resulting @ByteString@ is an immutable copy of the original @CStringLen@. +-- The @ByteString@ is a normal Haskell value and will be managed on the +-- Haskell heap. +packCStringLen :: CStringLen -> IO ByteString +packCStringLen (cstr, len) | len >= 0 = createFp len $ \fp -> + unsafeWithForeignPtr fp $ \p -> copyBytes p (castPtr cstr) len +packCStringLen (_, len) = + moduleErrorIO "packCStringLen" ("negative length: " ++ show len) + +------------------------------------------------------------------------ + +-- | /O(n)/ Make a copy of the 'ByteString' with its own storage. +-- This is mainly useful to allow the rest of the data pointed +-- to by the 'ByteString' to be garbage collected, for example +-- if a large string has been read in, and only a small part of it +-- is needed in the rest of the program. +-- +copy :: ByteString -> ByteString +copy (BS x l) = unsafeCreateFp l $ \p -> memcpyFp p x l + +-- --------------------------------------------------------------------- +-- Line IO + +-- | Read a line from stdin. +getLine :: IO ByteString +getLine = hGetLine stdin + +{-# DEPRECATED getLine + "Deprecated since @bytestring-0.12@. Use 'Data.ByteString.Char8.getLine' instead. (Functions that rely on ASCII encodings belong in \"Data.ByteString.Char8\")" + #-} + +-- | Read a line from a handle +hGetLine :: Handle -> IO ByteString +hGetLine h = + wantReadableHandle_ "Data.ByteString.hGetLine" h $ + \ h_@Handle__{haByteBuffer} -> do + flushCharReadBuffer h_ + buf <- readIORef haByteBuffer + if isEmptyBuffer buf + then fill h_ buf 0 [] + else haveBuf h_ buf 0 [] + where + + fill h_@Handle__{haByteBuffer,haDevice} buf !len xss = do + (r,buf') <- Buffered.fillReadBuffer haDevice buf + if r == 0 + then do writeIORef haByteBuffer buf{ bufR=0, bufL=0 } + if len > 0 + then mkBigPS len xss + else ioe_EOF + else haveBuf h_ buf' len xss + + haveBuf h_@Handle__{haByteBuffer} + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r } + len xss = + do + off <- findEOL r w raw + let new_len = len + off - r + xs <- mkPS raw r off + + -- if eol == True, then off is the offset of the '\n' + -- otherwise off == w and the buffer is now empty. + if off /= w + then do if w == off + 1 + then writeIORef haByteBuffer buf{ bufL=0, bufR=0 } + else writeIORef haByteBuffer buf{ bufL = off + 1 } + mkBigPS new_len (xs:xss) + else fill h_ buf{ bufL=0, bufR=0 } new_len (xs:xss) + + -- find the end-of-line character, if there is one + findEOL r w raw + | r == w = return w + | otherwise = do + c <- readWord8Buf raw r + if c == fromIntegral (ord '\n') + then return r -- NB. not r+1: don't include the '\n' + else findEOL (r+1) w raw + +{-# DEPRECATED hGetLine + "Deprecated since @bytestring-0.12@. Use 'Data.ByteString.Char8.hGetLine' instead. (Functions that rely on ASCII encodings belong in \"Data.ByteString.Char8\")" + #-} + +mkPS :: RawBuffer Word8 -> Int -> Int -> IO ByteString +mkPS buf start end = + createFp len $ \fp -> memcpyFp fp (buf `plusForeignPtr` start) len + where + len = end - start + +mkBigPS :: Int -> [ByteString] -> IO ByteString +mkBigPS _ [ps] = return ps +mkBigPS _ pss = return $! concat (P.reverse pss) + +-- --------------------------------------------------------------------- +-- Block IO + +-- | Outputs a 'ByteString' to the specified 'Handle'. +hPut :: Handle -> ByteString -> IO () +hPut _ (BS _ 0) = return () +hPut h (BS ps l) = unsafeWithForeignPtr ps $ \p-> hPutBuf h p l + +-- | Similar to 'hPut' except that it will never block. Instead it returns +-- any tail that did not get written. This tail may be 'empty' in the case that +-- the whole string was written, or the whole original string if nothing was +-- written. Partial writes are also possible. +-- +-- Note: on Windows and with Haskell implementation other than GHC, this +-- function does not work correctly; it behaves identically to 'hPut'. +-- +hPutNonBlocking :: Handle -> ByteString -> IO ByteString +hPutNonBlocking h bs@(BS ps l) = do + bytesWritten <- unsafeWithForeignPtr ps $ \p-> hPutBufNonBlocking h p l + return $! drop bytesWritten bs + +-- | A synonym for 'hPut', for compatibility +hPutStr :: Handle -> ByteString -> IO () +hPutStr = hPut + +-- | Write a ByteString to 'stdout'. +putStr :: ByteString -> IO () +putStr = hPut stdout + +------------------------------------------------------------------------ +-- Low level IO + +-- | Read a 'ByteString' directly from the specified 'Handle'. This +-- is far more efficient than reading the characters into a 'String' +-- and then using 'pack'. First argument is the Handle to read from, +-- and the second is the number of bytes to read. It returns the bytes +-- read, up to n, or 'empty' if EOF has been reached. +-- +-- 'hGet' is implemented in terms of 'hGetBuf'. +-- +-- If the handle is a pipe or socket, and the writing end +-- is closed, 'hGet' will behave as if EOF was reached. +-- +hGet :: Handle -> Int -> IO ByteString +hGet h i + | i > 0 = createFpAndTrim i $ \fp -> + unsafeWithForeignPtr fp $ \p -> hGetBuf h p i + | i == 0 = return empty + | otherwise = illegalBufferSize h "hGet" i + +-- | hGetNonBlocking is similar to 'hGet', except that it will never block +-- waiting for data to become available, instead it returns only whatever data +-- is available. If there is no data available to be read, 'hGetNonBlocking' +-- returns 'empty'. +-- +-- Note: on Windows and with Haskell implementation other than GHC, this +-- function does not work correctly; it behaves identically to 'hGet'. +-- +hGetNonBlocking :: Handle -> Int -> IO ByteString +hGetNonBlocking h i + | i > 0 = createFpAndTrim i $ \fp -> + unsafeWithForeignPtr fp $ \p -> hGetBufNonBlocking h p i + | i == 0 = return empty + | otherwise = illegalBufferSize h "hGetNonBlocking" i + +-- | Like 'hGet', except that a shorter 'ByteString' may be returned +-- if there are not enough bytes immediately available to satisfy the +-- whole request. 'hGetSome' only blocks if there is no data +-- available, and EOF has not yet been reached. +-- +hGetSome :: Handle -> Int -> IO ByteString +hGetSome hh i + | i > 0 = createFpAndTrim i $ \fp -> + unsafeWithForeignPtr fp $ \p -> hGetBufSome hh p i + | i == 0 = return empty + | otherwise = illegalBufferSize hh "hGetSome" i + +illegalBufferSize :: Handle -> String -> Int -> IO a +illegalBufferSize handle fn sz = + ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing) + --TODO: System.IO uses InvalidArgument here, but it's not exported :-( + where + msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz [] + + +-- | Read a handle's entire contents strictly into a 'ByteString'. +-- +-- This function reads chunks at a time, increasing the chunk size on each +-- read. The final string is then reallocated to the appropriate size. For +-- files > half of available memory, this may lead to memory exhaustion. +-- Consider using 'readFile' in this case. +-- +-- The Handle is closed once the contents have been read, +-- or if an exception is thrown. +-- +hGetContents :: Handle -> IO ByteString +hGetContents hnd = do + bs <- hGetContentsSizeHint hnd 1024 2048 + `finally` hClose hnd + -- don't waste too much space for small files: + if length bs < 900 + then return $! copy bs + else return bs + +hGetContentsSizeHint :: Handle + -> Int -- ^ first read size + -> Int -- ^ initial buffer size increment + -> IO ByteString +hGetContentsSizeHint hnd = + readChunks [] + where + readChunks chunks sz sz' = do + fp <- mallocByteString sz + readcount <- unsafeWithForeignPtr fp $ \buf -> hGetBuf hnd buf sz + let chunk = BS fp readcount + -- We rely on the hGetBuf behaviour (not hGetBufSome) where it reads up + -- to the size we ask for, or EOF. So short reads indicate EOF. + if readcount < sz && sz > 0 + then return $! concat (P.reverse (chunk : chunks)) + else readChunks (chunk : chunks) sz' ((sz+sz') `min` 32752) + -- we grow the buffer sizes, but not too huge + -- we concatenate in the end anyway + +-- | getContents. Read stdin strictly. Equivalent to hGetContents stdin +-- The 'Handle' is closed after the contents have been read. +-- +getContents :: IO ByteString +getContents = hGetContents stdin + +-- | The interact function takes a function of type @ByteString -> ByteString@ +-- as its argument. The entire input from the standard input device is passed +-- to this function as its argument, and the resulting string is output on the +-- standard output device. +-- +interact :: (ByteString -> ByteString) -> IO () +interact transformer = putStr . transformer =<< getContents + +-- | Read an entire file strictly into a 'ByteString'. +-- +readFile :: FilePath -> IO ByteString +readFile f = + withBinaryFile f ReadMode $ \h -> do + -- hFileSize fails if file is not regular file (like + -- /dev/null). Catch exception and try reading anyway. + filesz <- catch (hFileSize h) useZeroIfNotRegularFile + let readsz = (fromIntegral filesz `max` 0) + 1 + hGetContentsSizeHint h readsz (readsz `max` 255) + -- Our initial size is one bigger than the file size so that in the + -- typical case we will read the whole file in one go and not have + -- to allocate any more chunks. We'll still do the right thing if the + -- file size is 0 or is changed before we do the read. + where + useZeroIfNotRegularFile :: IOException -> IO Integer + useZeroIfNotRegularFile _ = return 0 + +modifyFile :: IOMode -> FilePath -> ByteString -> IO () +modifyFile mode f txt = withBinaryFile f mode (`hPut` txt) + +-- | Write a 'ByteString' to a file. +writeFile :: FilePath -> ByteString -> IO () +writeFile = modifyFile WriteMode + +-- | Append a 'ByteString' to a file. +appendFile :: FilePath -> ByteString -> IO () +appendFile = modifyFile AppendMode + +-- --------------------------------------------------------------------- +-- Internal utilities + +-- Common up near identical calls to `error' to reduce the number +-- constant strings created when compiled: +errorEmptyList :: HasCallStack => String -> a +errorEmptyList fun = moduleError fun "empty ByteString" +{-# NOINLINE errorEmptyList #-} + +moduleError :: HasCallStack => String -> String -> a +moduleError fun msg = error (moduleErrorMsg fun msg) +{-# NOINLINE moduleError #-} + +moduleErrorIO :: HasCallStack => String -> String -> IO a +moduleErrorIO fun msg = throwIO . userError $ moduleErrorMsg fun msg +{-# NOINLINE moduleErrorIO #-} + +moduleErrorMsg :: String -> String -> String +moduleErrorMsg fun msg = "Data.ByteString." ++ fun ++ ':':' ':msg + +-- Find from the end of the string using predicate +findFromEndUntil :: (Word8 -> Bool) -> ByteString -> Int +findFromEndUntil f ps@(BS _ l) = case unsnoc ps of + Nothing -> 0 + Just (b, c) -> + if f c + then l + else findFromEndUntil f b diff --git a/Data/ByteString/Builder.hs b/Data/ByteString/Builder.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder.hs @@ -0,0 +1,476 @@ +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + --instance Show Builder, instance IsString Builder + +{- | Copyright : (c) 2010 Jasper Van der Jeugt + (c) 2010 - 2011 Simon Meier +License : BSD3-style (see LICENSE) +Maintainer : Simon Meier +Portability : GHC + +'Builder's are used to efficiently construct sequences of bytes from + smaller parts. +Typically, + such a construction is part of the implementation of an /encoding/, i.e., + a function for converting Haskell values to sequences of bytes. +Examples of encodings are the generation of the sequence of bytes + representing a HTML document to be sent in a HTTP response by a + web application or the serialization of a Haskell value using + a fixed binary format. + +For an /efficient implementation of an encoding/, + it is important that (a) little time is spent on converting + the Haskell values to the resulting sequence of bytes /and/ + (b) that the representation of the resulting sequence + is such that it can be consumed efficiently. +'Builder's support (a) by providing an /O(1)/ concatentation operation + and efficient implementations of basic encodings for 'Char's, 'Int's, + and other standard Haskell values. +They support (b) by providing their result as a 'L.LazyByteString', + which is internally just a linked list of pointers to /chunks/ + of consecutive raw memory. +'L.LazyByteString's can be efficiently consumed by functions that + write them to a file or send them over a network socket. +Note that each chunk boundary incurs expensive extra work (e.g., a system call) + that must be amortized over the work spent on consuming the chunk body. +'Builder's therefore take special care to ensure that the + average chunk size is large enough. +The precise meaning of large enough is application dependent. +The current implementation is tuned + for an average chunk size between 4kb and 32kb, + which should suit most applications. + +As a simple example of an encoding implementation, + we show how to efficiently convert the following representation of mixed-data + tables to an UTF-8 encoded Comma-Separated-Values (CSV) table. + +>data Cell = StringC String +> | IntC Int +> deriving( Eq, Ord, Show ) +> +>type Row = [Cell] +>type Table = [Row] + +We use the following imports. + +@ +import qualified "Data.ByteString.Lazy" as L +import "Data.ByteString.Builder" +import Data.List ('Data.List.intersperse') +@ + +CSV is a character-based representation of tables. For maximal modularity, +we could first render @Table@s as 'String's and then encode this 'String' +using some Unicode character encoding. However, this sacrifices performance +due to the intermediate 'String' representation being built and thrown away +right afterwards. We get rid of this intermediate 'String' representation by +fixing the character encoding to UTF-8 and using 'Builder's to convert +@Table@s directly to UTF-8 encoded CSV tables represented as +'L.LazyByteString's. + +@ +encodeUtf8CSV :: Table -> L.LazyByteString +encodeUtf8CSV = 'toLazyByteString' . renderTable + +renderTable :: Table -> Builder +renderTable rs = 'mconcat' [renderRow r '<>' 'charUtf8' \'\\n\' | r <- rs] + +renderRow :: Row -> Builder +renderRow [] = 'mempty' +renderRow (c:cs) = + renderCell c \<\> mconcat [ charUtf8 \',\' \<\> renderCell c\' | c\' <- cs ] + +renderCell :: Cell -> Builder +renderCell (StringC cs) = renderString cs +renderCell (IntC i) = 'intDec' i + +renderString :: String -> Builder +renderString cs = charUtf8 \'\"\' \<\> 'foldMap' escape cs \<\> charUtf8 \'\"\' + where + escape \'\\\\\' = charUtf8 \'\\\\\' \<\> charUtf8 \'\\\\\' + escape \'\\\"\' = charUtf8 \'\\\\\' \<\> charUtf8 \'\\\"\' + escape c = charUtf8 c +@ + +Note that the ASCII encoding is a subset of the UTF-8 encoding, + which is why we can use the optimized function 'intDec' to + encode an 'Int' as a decimal number with UTF-8 encoded digits. +Using 'intDec' is more efficient than @'stringUtf8' . 'show'@, + as it avoids constructing an intermediate 'String'. +Avoiding this intermediate data structure significantly improves + performance because encoding @Cell@s is the core operation + for rendering CSV-tables. +See "Data.ByteString.Builder.Prim" for further + information on how to improve the performance of @renderString@. + +We demonstrate our UTF-8 CSV encoding function on the following table. + +@ +strings :: [String] +strings = [\"hello\", \"\\\"1\\\"\", \"λ-wörld\"] + +table :: Table +table = [map StringC strings, map IntC [-3..3]] +@ + +The expression @encodeUtf8CSV table@ results in the following lazy +'L.LazyByteString'. + +>Chunk "\"hello\",\"\\\"1\\\"\",\"\206\187-w\195\182rld\"\n-3,-2,-1,0,1,2,3\n" Empty + +We can clearly see that we are converting to a /binary/ format. The \'λ\' +and \'ö\' characters, which have a Unicode codepoint above 127, are +expanded to their corresponding UTF-8 multi-byte representation. + +We use the @criterion@ library () + to benchmark the efficiency of our encoding function on the following table. + +>import Criterion.Main -- add this import to the ones above +> +>maxiTable :: Table +>maxiTable = take 1000 $ cycle table +> +>main :: IO () +>main = defaultMain +> [ bench "encodeUtf8CSV maxiTable (original)" $ +> whnf (L.length . encodeUtf8CSV) maxiTable +> ] + +On a Core2 Duo 2.20GHz on a 32-bit Linux, + the above code takes 1ms to generate the 22'500 bytes long 'L.LazyByteString'. +Looking again at the definitions above, + we see that we took care to avoid intermediate data structures, + as otherwise we would sacrifice performance. +For example, + the following (arguably simpler) definition of @renderRow@ is about 20% slower. + +>renderRow :: Row -> Builder +>renderRow = mconcat . intersperse (charUtf8 ',') . map renderCell + +Similarly, using /O(n)/ concatentations like '++' or the equivalent 'Data.ByteString.concat' + operations on strict and 'L.LazyByteString's should be avoided. +The following definition of @renderString@ is also about 20% slower. + +>renderString :: String -> Builder +>renderString cs = charUtf8 $ "\"" ++ concatMap escape cs ++ "\"" +> where +> escape '\\' = "\\" +> escape '\"' = "\\\"" +> escape c = return c + +Apart from removing intermediate data-structures, + encodings can be optimized further by fine-tuning their execution + parameters using the functions in "Data.ByteString.Builder.Extra" and + their \"inner loops\" using the functions in + "Data.ByteString.Builder.Prim". +-} + + +module Data.ByteString.Builder + ( + -- * The Builder type + Builder + + -- * Executing Builders + -- | Internally, 'Builder's are buffer-filling functions. They are + -- executed by a /driver/ that provides them with an actual buffer to + -- fill. Once called with a buffer, a 'Builder' fills it and returns a + -- signal to the driver telling it that it is either done, has filled the + -- current buffer, or wants to directly insert a reference to a chunk of + -- memory. In the last two cases, the 'Builder' also returns a + -- continuation 'Builder' that the driver can call to fill the next + -- buffer. Here, we provide the two drivers that satisfy almost all use + -- cases. See "Data.ByteString.Builder.Extra", for information + -- about fine-tuning them. + , toLazyByteString + , hPutBuilder + , writeFile + + -- * Creating Builders + + -- ** Binary encodings + , byteString + , lazyByteString + , shortByteString + , int8 + , word8 + + -- *** Big-endian + , int16BE + , int32BE + , int64BE + + , word16BE + , word32BE + , word64BE + + , floatBE + , doubleBE + + -- *** Little-endian + , int16LE + , int32LE + , int64LE + + , word16LE + , word32LE + , word64LE + + , floatLE + , doubleLE + + -- ** Character encodings + -- | Conversion from 'Char' and 'String' into 'Builder's in various encodings. + + -- *** ASCII (Char7) + -- | The ASCII encoding is a 7-bit encoding. The /Char7/ encoding implemented here + -- works by truncating the Unicode codepoint to 7-bits, prefixing it + -- with a leading 0, and encoding the resulting 8-bits as a single byte. + -- For the codepoints 0-127 this corresponds the ASCII encoding. + , char7 + , string7 + + -- *** ISO/IEC 8859-1 (Char8) + -- | The ISO/IEC 8859-1 encoding is an 8-bit encoding often known as Latin-1. + -- The /Char8/ encoding implemented here works by truncating the Unicode codepoint + -- to 8-bits and encoding them as a single byte. For the codepoints 0-255 this corresponds + -- to the ISO/IEC 8859-1 encoding. + , char8 + , string8 + + -- *** UTF-8 + -- | The UTF-8 encoding can encode /all/ Unicode codepoints. We recommend + -- using it always for encoding 'Char's and 'String's unless an application + -- really requires another encoding. + , charUtf8 + , stringUtf8 + + , module Data.ByteString.Builder.ASCII + , module Data.ByteString.Builder.RealFloat + + ) where + +import Prelude hiding (writeFile) + +import Data.ByteString.Builder.Internal +import qualified Data.ByteString.Builder.Prim as P +import Data.ByteString.Builder.ASCII +import Data.ByteString.Builder.RealFloat + +import Data.String (IsString(..)) +import System.IO (Handle, IOMode(..), withBinaryFile) +import Foreign +import GHC.Base (unpackCString#, unpackCStringUtf8#, + unpackFoldrCString#, build) + +{- Not yet stable enough. + See note on 'hPut' in Data.ByteString.Builder.Internal +-} + +-- | Output a 'Builder' to a 'Handle'. +-- The 'Builder' is executed directly on the buffer of the 'Handle'. If the +-- buffer is too small (or not present), then it is replaced with a large +-- enough buffer. +-- +-- It is recommended that the 'Handle' is set to binary and +-- 'System.IO.BlockBuffering' mode. See 'System.IO.hSetBinaryMode' and +-- 'System.IO.hSetBuffering'. +-- +-- This function is more efficient than @hPut . 'toLazyByteString'@ because in +-- many cases no buffer allocation has to be done. Moreover, the results of +-- several executions of short 'Builder's are concatenated in the 'Handle's +-- buffer, therefore avoiding unnecessary buffer flushes. +hPutBuilder :: Handle -> Builder -> IO () +hPutBuilder h = hPut h . putBuilder + +modifyFile :: IOMode -> FilePath -> Builder -> IO () +modifyFile mode f bld = withBinaryFile f mode (`hPutBuilder` bld) + +-- | Write a 'Builder' to a file. +-- +-- Similarly to 'hPutBuilder', this function is more efficient than +-- using 'Data.ByteString.Lazy.hPut' . 'toLazyByteString' with a file handle. +-- +-- @since 0.11.2.0 +writeFile :: FilePath -> Builder -> IO () +writeFile = modifyFile WriteMode + +------------------------------------------------------------------------------ +-- Binary encodings +------------------------------------------------------------------------------ + +-- | Encode a single signed byte as-is. +-- +{-# INLINE int8 #-} +int8 :: Int8 -> Builder +int8 = P.primFixed P.int8 + +-- | Encode a single unsigned byte as-is. +-- +{-# INLINE word8 #-} +word8 :: Word8 -> Builder +word8 = P.primFixed P.word8 + + +------------------------------------------------------------------------------ +-- Binary little-endian encodings +------------------------------------------------------------------------------ + +-- | Encode an 'Int16' in little endian format. +{-# INLINE int16LE #-} +int16LE :: Int16 -> Builder +int16LE = P.primFixed P.int16LE + +-- | Encode an 'Int32' in little endian format. +{-# INLINE int32LE #-} +int32LE :: Int32 -> Builder +int32LE = P.primFixed P.int32LE + +-- | Encode an 'Int64' in little endian format. +{-# INLINE int64LE #-} +int64LE :: Int64 -> Builder +int64LE = P.primFixed P.int64LE + +-- | Encode a 'Word16' in little endian format. +{-# INLINE word16LE #-} +word16LE :: Word16 -> Builder +word16LE = P.primFixed P.word16LE + +-- | Encode a 'Word32' in little endian format. +{-# INLINE word32LE #-} +word32LE :: Word32 -> Builder +word32LE = P.primFixed P.word32LE + +-- | Encode a 'Word64' in little endian format. +{-# INLINE word64LE #-} +word64LE :: Word64 -> Builder +word64LE = P.primFixed P.word64LE + +-- | Encode a 'Float' in little endian format. +{-# INLINE floatLE #-} +floatLE :: Float -> Builder +floatLE = P.primFixed P.floatLE + +-- | Encode a 'Double' in little endian format. +{-# INLINE doubleLE #-} +doubleLE :: Double -> Builder +doubleLE = P.primFixed P.doubleLE + + +------------------------------------------------------------------------------ +-- Binary big-endian encodings +------------------------------------------------------------------------------ + +-- | Encode an 'Int16' in big endian format. +{-# INLINE int16BE #-} +int16BE :: Int16 -> Builder +int16BE = P.primFixed P.int16BE + +-- | Encode an 'Int32' in big endian format. +{-# INLINE int32BE #-} +int32BE :: Int32 -> Builder +int32BE = P.primFixed P.int32BE + +-- | Encode an 'Int64' in big endian format. +{-# INLINE int64BE #-} +int64BE :: Int64 -> Builder +int64BE = P.primFixed P.int64BE + +-- | Encode a 'Word16' in big endian format. +{-# INLINE word16BE #-} +word16BE :: Word16 -> Builder +word16BE = P.primFixed P.word16BE + +-- | Encode a 'Word32' in big endian format. +{-# INLINE word32BE #-} +word32BE :: Word32 -> Builder +word32BE = P.primFixed P.word32BE + +-- | Encode a 'Word64' in big endian format. +{-# INLINE word64BE #-} +word64BE :: Word64 -> Builder +word64BE = P.primFixed P.word64BE + +-- | Encode a 'Float' in big endian format. +{-# INLINE floatBE #-} +floatBE :: Float -> Builder +floatBE = P.primFixed P.floatBE + +-- | Encode a 'Double' in big endian format. +{-# INLINE doubleBE #-} +doubleBE :: Double -> Builder +doubleBE = P.primFixed P.doubleBE + +------------------------------------------------------------------------------ +-- ASCII encoding +------------------------------------------------------------------------------ + +-- | Char7 encode a 'Char'. +{-# INLINE char7 #-} +char7 :: Char -> Builder +char7 = P.primFixed P.char7 + +-- | Char7 encode a 'String'. +{-# INLINE string7 #-} +string7 :: String -> Builder +string7 = P.primMapListFixed P.char7 + +------------------------------------------------------------------------------ +-- ISO/IEC 8859-1 encoding +------------------------------------------------------------------------------ + +-- | Char8 encode a 'Char'. +{-# INLINE char8 #-} +char8 :: Char -> Builder +char8 = P.primFixed P.char8 + +-- | Char8 encode a 'String'. +{-# INLINE [1] string8 #-} -- phased to allow P.cstring rewrite +string8 :: String -> Builder +string8 = P.primMapListFixed P.char8 + +-- GHC desugars string literals with unpackCString# which the simplifier tends +-- to promptly turn into build (unpackFoldrCString# s), so we match on both. +{-# RULES +"string8/unpackCString#" forall s. + string8 (unpackCString# s) = P.cstring s + +"string8/unpackFoldrCString#" forall s. + string8 (build (unpackFoldrCString# s)) = P.cstring s + #-} + +------------------------------------------------------------------------------ +-- UTF-8 encoding +------------------------------------------------------------------------------ + +-- | UTF-8 encode a 'Char'. +{-# INLINE charUtf8 #-} +charUtf8 :: Char -> Builder +charUtf8 = P.primBounded P.charUtf8 + +-- | UTF-8 encode a 'String'. +-- +-- Note that 'stringUtf8' performs no codepoint validation and consequently may +-- emit invalid UTF-8 if asked (e.g. single surrogates). +{-# INLINE [1] stringUtf8 #-} -- phased to allow P.cstring rewrite +stringUtf8 :: String -> Builder +stringUtf8 = P.primMapListBounded P.charUtf8 + +{-# RULES +"stringUtf8/unpackCStringUtf8#" forall s. + stringUtf8 (unpackCStringUtf8# s) = P.cstringUtf8 s + +"stringUtf8/unpackCString#" forall s. + stringUtf8 (unpackCString# s) = P.cstring s + +"stringUtf8/unpackFoldrCString#" forall s. + stringUtf8 (build (unpackFoldrCString# s)) = P.cstring s + #-} + +instance IsString Builder where + fromString = stringUtf8 + +-- | @since 0.11.1.0 +instance Show Builder where + show = show . toLazyByteString diff --git a/Data/ByteString/Builder/ASCII.hs b/Data/ByteString/Builder/ASCII.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/ASCII.hs @@ -0,0 +1,315 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | Copyright : (c) 2010 - 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +-- Constructing 'Builder's using ASCII-based encodings. +-- +module Data.ByteString.Builder.ASCII + ( + -- ** Formatting numbers as text + -- | Formatting of numbers as ASCII text. + -- + -- Note that you can also use these functions for the ISO/IEC 8859-1 and + -- UTF-8 encodings, as the ASCII encoding is equivalent on the + -- codepoints 0-127. + + -- *** Decimal numbers + -- | Decimal encoding of numbers using ASCII encoded characters. + int8Dec + , int16Dec + , int32Dec + , int64Dec + , intDec + , integerDec + + , word8Dec + , word16Dec + , word32Dec + , word64Dec + , wordDec + + , floatDec + , doubleDec + + -- *** Hexadecimal numbers + + -- | Encoding positive integers as hexadecimal numbers using lower-case + -- ASCII characters. The shortest + -- possible representation is used. For example, + -- + -- >>> toLazyByteString (word16Hex 0x0a10) + -- Chunk "a10" Empty + -- + -- Note that there is no support for using upper-case characters. Please + -- contact the maintainer, if your application cannot work without + -- hexadecimal encodings that use upper-case characters. + -- + , word8Hex + , word16Hex + , word32Hex + , word64Hex + , wordHex + + -- *** Fixed-width hexadecimal numbers + -- + , int8HexFixed + , int16HexFixed + , int32HexFixed + , int64HexFixed + , word8HexFixed + , word16HexFixed + , word32HexFixed + , word64HexFixed + + , floatHexFixed + , doubleHexFixed + + , byteStringHex + , lazyByteStringHex + + ) where + +import Data.ByteString as S +import Data.ByteString.Lazy as L +import Data.ByteString.Builder.Internal (Builder) +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Builder.Prim.Internal as P +import Data.ByteString.Builder.RealFloat (floatDec, doubleDec) +import Data.ByteString.Internal.Type (c_int_dec_padded9, c_long_long_int_dec_padded18) + +import Foreign +import Data.List.NonEmpty (NonEmpty(..)) + +------------------------------------------------------------------------------ +-- Decimal Encoding +------------------------------------------------------------------------------ + +-- Signed integers +------------------ + +-- | Decimal encoding of an 'Int8' using the ASCII digits. +-- +-- e.g. +-- +-- > toLazyByteString (int8Dec 42) = "42" +-- > toLazyByteString (int8Dec (-1)) = "-1" +-- +{-# INLINE int8Dec #-} +int8Dec :: Int8 -> Builder +int8Dec = P.primBounded P.int8Dec + +-- | Decimal encoding of an 'Int16' using the ASCII digits. +{-# INLINE int16Dec #-} +int16Dec :: Int16 -> Builder +int16Dec = P.primBounded P.int16Dec + +-- | Decimal encoding of an 'Int32' using the ASCII digits. +{-# INLINE int32Dec #-} +int32Dec :: Int32 -> Builder +int32Dec = P.primBounded P.int32Dec + +-- | Decimal encoding of an 'Int64' using the ASCII digits. +{-# INLINE int64Dec #-} +int64Dec :: Int64 -> Builder +int64Dec = P.primBounded P.int64Dec + +-- | Decimal encoding of an 'Int' using the ASCII digits. +{-# INLINE intDec #-} +intDec :: Int -> Builder +intDec = P.primBounded P.intDec + + +-- Unsigned integers +-------------------- + +-- | Decimal encoding of a 'Word8' using the ASCII digits. +{-# INLINE word8Dec #-} +word8Dec :: Word8 -> Builder +word8Dec = P.primBounded P.word8Dec + +-- | Decimal encoding of a 'Word16' using the ASCII digits. +{-# INLINE word16Dec #-} +word16Dec :: Word16 -> Builder +word16Dec = P.primBounded P.word16Dec + +-- | Decimal encoding of a 'Word32' using the ASCII digits. +{-# INLINE word32Dec #-} +word32Dec :: Word32 -> Builder +word32Dec = P.primBounded P.word32Dec + +-- | Decimal encoding of a 'Word64' using the ASCII digits. +{-# INLINE word64Dec #-} +word64Dec :: Word64 -> Builder +word64Dec = P.primBounded P.word64Dec + +-- | Decimal encoding of a 'Word' using the ASCII digits. +{-# INLINE wordDec #-} +wordDec :: Word -> Builder +wordDec = P.primBounded P.wordDec + + +------------------------------------------------------------------------------ +-- Hexadecimal Encoding +------------------------------------------------------------------------------ + +-- without lead +--------------- + +-- | Shortest hexadecimal encoding of a 'Word8' using lower-case characters. +{-# INLINE word8Hex #-} +word8Hex :: Word8 -> Builder +word8Hex = P.primBounded P.word8Hex + +-- | Shortest hexadecimal encoding of a 'Word16' using lower-case characters. +{-# INLINE word16Hex #-} +word16Hex :: Word16 -> Builder +word16Hex = P.primBounded P.word16Hex + +-- | Shortest hexadecimal encoding of a 'Word32' using lower-case characters. +{-# INLINE word32Hex #-} +word32Hex :: Word32 -> Builder +word32Hex = P.primBounded P.word32Hex + +-- | Shortest hexadecimal encoding of a 'Word64' using lower-case characters. +{-# INLINE word64Hex #-} +word64Hex :: Word64 -> Builder +word64Hex = P.primBounded P.word64Hex + +-- | Shortest hexadecimal encoding of a 'Word' using lower-case characters. +{-# INLINE wordHex #-} +wordHex :: Word -> Builder +wordHex = P.primBounded P.wordHex + + +-- fixed width; leading zeroes +------------------------------ + +-- | Encode a 'Int8' using 2 nibbles (hexadecimal digits). +{-# INLINE int8HexFixed #-} +int8HexFixed :: Int8 -> Builder +int8HexFixed = P.primFixed P.int8HexFixed + +-- | Encode a 'Int16' using 4 nibbles. +{-# INLINE int16HexFixed #-} +int16HexFixed :: Int16 -> Builder +int16HexFixed = P.primFixed P.int16HexFixed + +-- | Encode a 'Int32' using 8 nibbles. +{-# INLINE int32HexFixed #-} +int32HexFixed :: Int32 -> Builder +int32HexFixed = P.primFixed P.int32HexFixed + +-- | Encode a 'Int64' using 16 nibbles. +{-# INLINE int64HexFixed #-} +int64HexFixed :: Int64 -> Builder +int64HexFixed = P.primFixed P.int64HexFixed + +-- | Encode a 'Word8' using 2 nibbles (hexadecimal digits). +{-# INLINE word8HexFixed #-} +word8HexFixed :: Word8 -> Builder +word8HexFixed = P.primFixed P.word8HexFixed + +-- | Encode a 'Word16' using 4 nibbles. +{-# INLINE word16HexFixed #-} +word16HexFixed :: Word16 -> Builder +word16HexFixed = P.primFixed P.word16HexFixed + +-- | Encode a 'Word32' using 8 nibbles. +{-# INLINE word32HexFixed #-} +word32HexFixed :: Word32 -> Builder +word32HexFixed = P.primFixed P.word32HexFixed + +-- | Encode a 'Word64' using 16 nibbles. +{-# INLINE word64HexFixed #-} +word64HexFixed :: Word64 -> Builder +word64HexFixed = P.primFixed P.word64HexFixed + +-- | Encode an IEEE 'Float' using 8 nibbles. +{-# INLINE floatHexFixed #-} +floatHexFixed :: Float -> Builder +floatHexFixed = P.primFixed P.floatHexFixed + +-- | Encode an IEEE 'Double' using 16 nibbles. +{-# INLINE doubleHexFixed #-} +doubleHexFixed :: Double -> Builder +doubleHexFixed = P.primFixed P.doubleHexFixed + +-- | Encode each byte of a 'S.StrictByteString' using its fixed-width hex encoding. +{-# NOINLINE byteStringHex #-} -- share code +byteStringHex :: S.StrictByteString -> Builder +byteStringHex = P.primMapByteStringFixed P.word8HexFixed + +-- | Encode each byte of a 'L.LazyByteString' using its fixed-width hex encoding. +{-# NOINLINE lazyByteStringHex #-} -- share code +lazyByteStringHex :: L.LazyByteString -> Builder +lazyByteStringHex = P.primMapLazyByteStringFixed P.word8HexFixed + + +------------------------------------------------------------------------------ +-- Fast decimal 'Integer' encoding. +------------------------------------------------------------------------------ + +-- An optimized version of the integer serialization code +-- in blaze-textual (c) 2011 MailRank, Inc. Bryan O'Sullivan +-- . It is 2.5x faster on Int-sized integers and 4.5x faster +-- on larger integers. + +-- | Maximal power of 10 fitting into an 'Int' without using the MSB. +-- 10 ^ 9 for 32 bit ints (31 * log 2 / log 10 = 9.33) +-- 10 ^ 18 for 64 bit ints (63 * log 2 / log 10 = 18.96) +-- +-- FIXME: Think about also using the MSB. For 64 bit 'Int's this makes a +-- difference. +maxPow10 :: Integer +maxPow10 = toInteger $ (10 :: Int) ^ P.caseWordSize_32_64 (9 :: Int) 18 + +-- | Decimal encoding of an 'Integer' using the ASCII digits. +integerDec :: Integer -> Builder +integerDec i + | i' <- fromInteger i, toInteger i' == i = intDec i' + | i < 0 = P.primFixed P.char8 '-' `mappend` go (-i) + | otherwise = go i + where + go :: Integer -> Builder + go n | n < maxPow10 = intDec (fromInteger n) + | otherwise = + case putH (splitf (maxPow10 * maxPow10) n) of + x:|xs -> intDec x `mappend` P.primMapListBounded intDecPadded xs + + splitf :: Integer -> Integer -> NonEmpty Integer + splitf pow10 n0 + | pow10 > n0 = n0 :| [] + | otherwise = splith (splitf (pow10 * pow10) n0) + where + splith (n:|ns) = + case n `quotRem` pow10 of + (q,r) | q > 0 -> q :| r : splitb ns + | otherwise -> r :| splitb ns + + splitb [] = [] + splitb (n:ns) = case n `quotRem` pow10 of + (q,r) -> q : r : splitb ns + + putH :: NonEmpty Integer -> NonEmpty Int + putH (n:|ns) = case n `quotRem` maxPow10 of + (x,y) + | q > 0 -> q :| r : putB ns + | otherwise -> r :| putB ns + where q = fromInteger x + r = fromInteger y + + putB :: [Integer] -> [Int] + putB [] = [] + putB (n:ns) = case n `quotRem` maxPow10 of + (q,r) -> fromInteger q : fromInteger r : putB ns + + +{-# INLINE intDecPadded #-} +intDecPadded :: P.BoundedPrim Int +intDecPadded = P.liftFixedToBounded $ P.caseWordSize_32_64 + (P.fixedPrim 9 $ c_int_dec_padded9 . fromIntegral) + (P.fixedPrim 18 $ c_long_long_int_dec_padded18 . fromIntegral) diff --git a/Data/ByteString/Builder/Extra.hs b/Data/ByteString/Builder/Extra.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Extra.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | Copyright : (c) 2010 Jasper Van der Jeugt +-- (c) 2010-2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +-- Extra functions for creating and executing 'Builder's. They are intended +-- for application-specific fine-tuning the performance of 'Builder's. +-- +----------------------------------------------------------------------------- +module Data.ByteString.Builder.Extra + ( + -- * Execution strategies + toLazyByteStringWith + , AllocationStrategy + , safeStrategy + , untrimmedStrategy + , smallChunkSize + , defaultChunkSize + + -- * Controlling chunk boundaries + , byteStringCopy + , byteStringInsert + , byteStringThreshold + + , lazyByteStringCopy + , lazyByteStringInsert + , lazyByteStringThreshold + + , flush + + -- * Low level execution + , BufferWriter + , Next(..) + , runBuilder + + -- * Host-specific binary encodings + , intHost + , int16Host + , int32Host + , int64Host + + , wordHost + , word16Host + , word32Host + , word64Host + + , floatHost + , doubleHost + + ) where + + +import Data.ByteString.Builder.Internal + ( Builder, toLazyByteStringWith + , AllocationStrategy, safeStrategy, untrimmedStrategy + , smallChunkSize, defaultChunkSize, flush + , byteStringCopy, byteStringInsert, byteStringThreshold + , lazyByteStringCopy, lazyByteStringInsert, lazyByteStringThreshold ) + +import qualified Data.ByteString.Builder.Internal as I +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Internal as S + +import Foreign + +------------------------------------------------------------------------------ +-- Builder execution public API +------------------------------------------------------------------------------ + +-- | A 'BufferWriter' represents the result of running a 'Builder'. +-- It unfolds as a sequence of chunks of data. These chunks come in two forms: +-- +-- * an IO action for writing the Builder's data into a user-supplied memory +-- buffer. +-- +-- * a pre-existing chunks of data represented by a 'S.StrictByteString' +-- +-- While this is rather low level, it provides you with full flexibility in +-- how the data is written out. +-- +-- The 'BufferWriter' itself is an IO action: you supply it with a buffer +-- (as a pointer and length) and it will write data into the buffer. +-- It returns a number indicating how many bytes were actually written +-- (which can be @0@). It also returns a 'Next' which describes what +-- comes next. +-- +type BufferWriter = Ptr Word8 -> Int -> IO (Int, Next) + +-- | After running a 'BufferWriter' action there are three possibilities for +-- what comes next: +-- +data Next = + -- | This means we're all done. All the builder data has now been written. + Done + + -- | This indicates that there may be more data to write. It + -- gives you the next 'BufferWriter' action. You should call that action + -- with an appropriate buffer. The int indicates the /minimum/ buffer size + -- required by the next 'BufferWriter' action. That is, if you call the next + -- action you /must/ supply it with a buffer length of at least this size. + | More !Int BufferWriter + + -- | In addition to the data that has just been written into your buffer + -- by the 'BufferWriter' action, it gives you a pre-existing chunk + -- of data as a 'S.StrictByteString'. It also gives you the following 'BufferWriter' + -- action. It is safe to run this following action using a buffer with as + -- much free space as was left by the previous run action. + | Chunk !S.StrictByteString BufferWriter + +-- | Turn a 'Builder' into its initial 'BufferWriter' action. +-- +runBuilder :: Builder -> BufferWriter +runBuilder = run . I.runBuilder + where + bytesWritten startPtr endPtr = endPtr `minusPtr` startPtr + + run :: I.BuildStep () -> BufferWriter + run step = \buf len -> + let doneH endPtr () = + let !wc = bytesWritten buf endPtr + next = Done + in return (wc, next) + + bufferFullH endPtr minReq step' = + let !wc = bytesWritten buf endPtr + next = More minReq (run step') + in return (wc, next) + + insertChunkH endPtr bs step' = + let !wc = bytesWritten buf endPtr + next = Chunk bs (run step') + in return (wc, next) + + br = I.BufferRange buf (buf `plusPtr` len) + + in I.fillWithBuildStep step doneH bufferFullH insertChunkH br + + + +------------------------------------------------------------------------------ +-- Host-specific encodings +------------------------------------------------------------------------------ + +-- | Encode a single native machine 'Int'. The 'Int' is encoded in host order, +-- host endian form, for the machine you're on. On a 64 bit machine the 'Int' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way +-- are not portable to different endian or int sized machines, without +-- conversion. +-- +{-# INLINE intHost #-} +intHost :: Int -> Builder +intHost = P.primFixed P.intHost + +-- | Encode a 'Int16' in native host order and host endianness. +{-# INLINE int16Host #-} +int16Host :: Int16 -> Builder +int16Host = P.primFixed P.int16Host + +-- | Encode a 'Int32' in native host order and host endianness. +{-# INLINE int32Host #-} +int32Host :: Int32 -> Builder +int32Host = P.primFixed P.int32Host + +-- | Encode a 'Int64' in native host order and host endianness. +{-# INLINE int64Host #-} +int64Host :: Int64 -> Builder +int64Host = P.primFixed P.int64Host + +-- | Encode a single native machine 'Word'. The 'Word' is encoded in host order, +-- host endian form, for the machine you're on. On a 64 bit machine the 'Word' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way +-- are not portable to different endian or word sized machines, without +-- conversion. +-- +{-# INLINE wordHost #-} +wordHost :: Word -> Builder +wordHost = P.primFixed P.wordHost + +-- | Encode a 'Word16' in native host order and host endianness. +{-# INLINE word16Host #-} +word16Host :: Word16 -> Builder +word16Host = P.primFixed P.word16Host + +-- | Encode a 'Word32' in native host order and host endianness. +{-# INLINE word32Host #-} +word32Host :: Word32 -> Builder +word32Host = P.primFixed P.word32Host + +-- | Encode a 'Word64' in native host order and host endianness. +{-# INLINE word64Host #-} +word64Host :: Word64 -> Builder +word64Host = P.primFixed P.word64Host + +-- | Encode a 'Float' in native host order. Values encoded this way are not +-- portable to different endian machines, without conversion. +{-# INLINE floatHost #-} +floatHost :: Float -> Builder +floatHost = P.primFixed P.floatHost + +-- | Encode a 'Double' in native host order. +{-# INLINE doubleHost #-} +doubleHost :: Double -> Builder +doubleHost = P.primFixed P.doubleHost + diff --git a/Data/ByteString/Builder/Internal.hs b/Data/ByteString/Builder/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Internal.hs @@ -0,0 +1,1219 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +{-# OPTIONS_HADDOCK not-home #-} + +-- | Copyright : (c) 2010 - 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : unstable, private +-- Portability : GHC +-- +-- *Warning:* this module is internal. If you find that you need it then please +-- contact the maintainers and explain what you are trying to do and discuss +-- what you would need in the public API. It is important that you do this as +-- the module may not be exposed at all in future releases. +-- +-- Core types and functions for the 'Builder' monoid and its generalization, +-- the 'Put' monad. +-- +-- The design of the 'Builder' monoid is optimized such that +-- +-- 1. buffers of arbitrary size can be filled as efficiently as possible and +-- +-- 2. sequencing of 'Builder's is as cheap as possible. +-- +-- We achieve (1) by completely handing over control over writing to the buffer +-- to the 'BuildStep' implementing the 'Builder'. This 'BuildStep' is just told +-- the start and the end of the buffer (represented as a 'BufferRange'). Then, +-- the 'BuildStep' can write to as big a prefix of this 'BufferRange' in any +-- way it desires. If the 'BuildStep' is done, the 'BufferRange' is full, or a +-- long sequence of bytes should be inserted directly, then the 'BuildStep' +-- signals this to its caller using a 'BuildSignal'. +-- +-- We achieve (2) by requiring that every 'Builder' is implemented by a +-- 'BuildStep' that takes a continuation 'BuildStep', which it calls with the +-- updated 'BufferRange' after it is done. Therefore, only two pointers have +-- to be passed in a function call to implement concatenation of 'Builder's. +-- Moreover, many 'Builder's are completely inlined, which enables the compiler +-- to sequence them without a function call and with no boxing at all. +-- +-- This design gives the implementation of a 'Builder' full access to the 'IO' +-- monad. Therefore, utmost care has to be taken to not overwrite anything +-- outside the given 'BufferRange's. Moreover, further care has to be taken to +-- ensure that 'Builder's and 'Put's are referentially transparent. See the +-- comments of the 'builder' and 'put' functions for further information. +-- Note that there are /no safety belts/ at all, when implementing a 'Builder' +-- using an 'IO' action: you are writing code that might enable the next +-- buffer-overflow attack on a Haskell server! +-- +module Data.ByteString.Builder.Internal ( + -- * Buffer management + Buffer(..) + , BufferRange(..) + , newBuffer + , bufferSize + , byteStringFromBuffer + + , ChunkIOStream(..) + , buildStepToCIOS + , ciosUnitToLazyByteString + , ciosToLazyByteString + + -- * Build signals and steps + , BuildSignal + , BuildStep + , finalBuildStep + + , done + , bufferFull + , insertChunk + + , fillWithBuildStep + + -- * The Builder monoid + , Builder + , builder + , runBuilder + , runBuilderWith + + -- ** Primitive combinators + , empty + , append + , flush + , ensureFree + -- , sizedChunksInsert + + , byteStringCopy + , byteStringInsert + , byteStringThreshold + + , lazyByteStringCopy + , lazyByteStringInsert + , lazyByteStringThreshold + + , shortByteString + + , maximalCopySize + , byteString + , lazyByteString + + -- ** Execution + , toLazyByteString + , toLazyByteStringWith + , AllocationStrategy + , safeStrategy + , untrimmedStrategy + , customStrategy + , L.smallChunkSize + , L.defaultChunkSize + , L.chunkOverhead + + -- * The Put monad + , Put + , put + , runPut + + -- ** Execution + , putToLazyByteString + , putToLazyByteStringWith + , hPut + + -- ** Conversion to and from Builders + , putBuilder + , fromPut + + -- -- ** Lifting IO actions + -- , putLiftIO + +) where + +import Control.Arrow (second) +import Control.DeepSeq (NFData(..)) +import GHC.Exts (IsList(..)) + +import Data.Semigroup (Semigroup(..)) +import Data.List.NonEmpty (NonEmpty(..)) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Unsafe as S +import qualified Data.ByteString.Internal.Type as S +import qualified Data.ByteString.Lazy.Internal as L +import qualified Data.ByteString.Short.Internal as Sh + +import qualified GHC.IO.Buffer as IO (Buffer(..), newByteBuffer) +import GHC.IO.Handle.Internals (wantWritableHandle, flushWriteBuffer) +import GHC.IO.Handle.Types (Handle__, haByteBuffer, haBufferMode) +import System.IO (hFlush, BufferMode(..), Handle) +import Data.IORef + +import Foreign +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import System.IO.Unsafe (unsafeDupablePerformIO) + +------------------------------------------------------------------------------ +-- Buffers +------------------------------------------------------------------------------ +-- | A range of bytes in a buffer represented by the pointer to the first byte +-- of the range and the pointer to the first byte /after/ the range. +data BufferRange = BufferRange {-# UNPACK #-} !(Ptr Word8) -- First byte of range + {-# UNPACK #-} !(Ptr Word8) -- First byte /after/ range + +-- | @since 0.12.2.0 +instance NFData BufferRange where + rnf !_ = () + +-- | A 'Buffer' together with the 'BufferRange' of free bytes. The filled +-- space starts at offset 0 and ends at the first free byte. +data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) + {-# UNPACK #-} !BufferRange + +-- | Like the @NFData@ instance for @StrictByteString@, +-- this does not force the @ForeignPtrContents@ field +-- of the underlying @ForeignPtr@. +-- +-- @since 0.12.2.0 +instance NFData Buffer where + rnf !_ = () + +-- | Combined size of the filled and free space in the buffer. +{-# INLINE bufferSize #-} +bufferSize :: Buffer -> Int +bufferSize (Buffer fpbuf (BufferRange _ ope)) = + ope `minusPtr` unsafeForeignPtrToPtr fpbuf + +-- | Allocate a new buffer of the given size. +{-# INLINE newBuffer #-} +newBuffer :: Int -> IO Buffer +newBuffer size = do + fpbuf <- S.mallocByteString size + let pbuf = unsafeForeignPtrToPtr fpbuf + return $! Buffer fpbuf (BufferRange pbuf (pbuf `plusPtr` size)) + +-- | Convert the filled part of a 'Buffer' to a 'S.StrictByteString'. +{-# INLINE byteStringFromBuffer #-} +byteStringFromBuffer :: Buffer -> S.StrictByteString +byteStringFromBuffer (Buffer fpbuf (BufferRange op _)) = + S.BS fpbuf (op `minusPtr` unsafeForeignPtrToPtr fpbuf) + +-- | Prepend the filled part of a 'Buffer' to a 'L.LazyByteString' +-- trimming it if necessary. +{-# INLINE trimmedChunkFromBuffer #-} +trimmedChunkFromBuffer :: AllocationStrategy -> Buffer + -> L.LazyByteString -> L.LazyByteString +trimmedChunkFromBuffer (AllocationStrategy _ _ trim) buf k + | S.null bs = k + | trim (S.length bs) (bufferSize buf) = L.Chunk (S.copy bs) k + | otherwise = L.Chunk bs k + where + bs = byteStringFromBuffer buf + +------------------------------------------------------------------------------ +-- Chunked IO Stream +------------------------------------------------------------------------------ + +-- | A stream of chunks that are constructed in the 'IO' monad. +-- +-- This datatype serves as the common interface for the buffer-by-buffer +-- execution of a 'BuildStep' by 'buildStepToCIOS'. Typical users of this +-- interface are 'ciosToLazyByteString' or iteratee-style libraries like +-- @enumerator@. +data ChunkIOStream a = + Finished Buffer a + -- ^ The partially filled last buffer together with the result. + | Yield1 S.StrictByteString (IO (ChunkIOStream a)) + -- ^ Yield a /non-empty/ 'S.StrictByteString'. + +-- | A smart constructor for yielding one chunk that ignores the chunk if +-- it is empty. +{-# INLINE yield1 #-} +yield1 :: S.StrictByteString -> IO (ChunkIOStream a) -> IO (ChunkIOStream a) +yield1 bs cios | S.null bs = cios + | otherwise = return $ Yield1 bs cios + +-- | Convert a @'ChunkIOStream' ()@ to a 'L.LazyByteString' using +-- 'unsafeDupablePerformIO'. +{-# INLINE ciosUnitToLazyByteString #-} +ciosUnitToLazyByteString :: AllocationStrategy + -> L.LazyByteString -> ChunkIOStream () -> L.LazyByteString +ciosUnitToLazyByteString strategy k = go + where + go (Finished buf _) = trimmedChunkFromBuffer strategy buf k + go (Yield1 bs io) = L.Chunk bs $ unsafeDupablePerformIO (go <$> io) + +-- | Convert a 'ChunkIOStream' to a lazy tuple of the result and the written +-- 'L.LazyByteString' using 'unsafeDupablePerformIO'. +{-# INLINE ciosToLazyByteString #-} +ciosToLazyByteString :: AllocationStrategy + -> (a -> (b, L.LazyByteString)) + -> ChunkIOStream a + -> (b, L.LazyByteString) +ciosToLazyByteString strategy k = + go + where + go (Finished buf x) = + second (trimmedChunkFromBuffer strategy buf) $ k x + go (Yield1 bs io) = second (L.Chunk bs) $ unsafeDupablePerformIO (go <$> io) + +------------------------------------------------------------------------------ +-- Build signals +------------------------------------------------------------------------------ + +-- | 'BuildStep's may be called *multiple times* and they must not rise an +-- async. exception. +type BuildStep a = BufferRange -> IO (BuildSignal a) + +-- | 'BuildSignal's abstract signals to the caller of a 'BuildStep'. There are +-- three signals: 'done', 'bufferFull', or 'insertChunks signals +data BuildSignal a = + Done {-# UNPACK #-} !(Ptr Word8) a + | BufferFull + {-# UNPACK #-} !Int + {-# UNPACK #-} !(Ptr Word8) + (BuildStep a) + | InsertChunk + {-# UNPACK #-} !(Ptr Word8) + S.StrictByteString + (BuildStep a) + +-- | Signal that the current 'BuildStep' is done and has computed a value. +{-# INLINE done #-} +done :: Ptr Word8 -- ^ Next free byte in current 'BufferRange' + -> a -- ^ Computed value + -> BuildSignal a +done = Done + +-- | Signal that the current buffer is full. +{-# INLINE bufferFull #-} +bufferFull :: Int + -- ^ Minimal size of next 'BufferRange'. + -> Ptr Word8 + -- ^ Next free byte in current 'BufferRange'. + -> BuildStep a + -- ^ 'BuildStep' to run on the next 'BufferRange'. This 'BuildStep' + -- may assume that it is called with a 'BufferRange' of at least the + -- required minimal size; i.e., the caller of this 'BuildStep' must + -- guarantee this. + -> BuildSignal a +bufferFull = BufferFull + + +-- | Signal that a 'S.StrictByteString' chunk should be inserted directly. +{-# INLINE insertChunk #-} +insertChunk :: Ptr Word8 + -- ^ Next free byte in current 'BufferRange' + -> S.StrictByteString + -- ^ Chunk to insert. + -> BuildStep a + -- ^ 'BuildStep' to run on next 'BufferRange' + -> BuildSignal a +insertChunk = InsertChunk + + +-- | Fill a 'BufferRange' using a 'BuildStep'. +{-# INLINE fillWithBuildStep #-} +fillWithBuildStep + :: BuildStep a + -- ^ Build step to use for filling the 'BufferRange'. + -> (Ptr Word8 -> a -> IO b) + -- ^ Handling the 'done' signal + -> (Ptr Word8 -> Int -> BuildStep a -> IO b) + -- ^ Handling the 'bufferFull' signal + -> (Ptr Word8 -> S.StrictByteString -> BuildStep a -> IO b) + -- ^ Handling the 'insertChunk' signal + -> BufferRange + -- ^ Buffer range to fill. + -> IO b + -- ^ Value computed while filling this 'BufferRange'. +fillWithBuildStep step fDone fFull fChunk !br = do + signal <- step br + case signal of + Done op x -> fDone op x + BufferFull minSize op nextStep -> fFull op minSize nextStep + InsertChunk op bs nextStep -> fChunk op bs nextStep + + +------------------------------------------------------------------------------ +-- The 'Builder' monoid +------------------------------------------------------------------------------ + +-- | 'Builder's denote sequences of bytes. +-- They are 'Monoid's where +-- 'mempty' is the zero-length sequence and +-- 'mappend' is concatenation, which runs in /O(1)/. +newtype Builder = Builder (forall r. BuildStep r -> BuildStep r) + +-- | Construct a 'Builder'. In contrast to 'BuildStep's, 'Builder's are +-- referentially transparent. +{-# INLINE builder #-} +builder :: (forall r. BuildStep r -> BuildStep r) + -- ^ A function that fills a 'BufferRange', calls the continuation with + -- the updated 'BufferRange' once its done, and signals its caller how + -- to proceed using 'done', 'bufferFull', or 'insertChunk'. + -- + -- This function must be referentially transparent; i.e., calling it + -- multiple times with equally sized 'BufferRange's must result in the + -- same sequence of bytes being written. If you need mutable state, + -- then you must allocate it anew upon each call of this function. + -- Moreover, this function must call the continuation once its done. + -- Otherwise, concatenation of 'Builder's does not work. Finally, this + -- function must write to all bytes that it claims it has written. + -- Otherwise, the resulting 'Builder' is not guaranteed to be + -- referentially transparent and sensitive data might leak. + -> Builder +builder = Builder + +-- | The final build step that returns the 'done' signal. +finalBuildStep :: BuildStep () +finalBuildStep (BufferRange op _) = return $ Done op () + +-- | Run a 'Builder' with the 'finalBuildStep'. +{-# INLINE runBuilder #-} +runBuilder :: Builder -- ^ 'Builder' to run + -> BuildStep () -- ^ 'BuildStep' that writes the byte stream of this + -- 'Builder' and signals 'done' upon completion. +runBuilder b = runBuilderWith b finalBuildStep + +-- | Run a 'Builder'. +{-# INLINE runBuilderWith #-} +runBuilderWith :: Builder -- ^ 'Builder' to run + -> BuildStep a -- ^ Continuation 'BuildStep' + -> BuildStep a +runBuilderWith (Builder b) = b + +-- | The 'Builder' denoting a zero-length sequence of bytes. This function is +-- only exported for use in rewriting rules. Use 'mempty' otherwise. +{-# INLINE[1] empty #-} +empty :: Builder +empty = Builder (\k br -> k br) +-- This eta expansion (hopefully) allows GHC to worker-wrapper the +-- 'BufferRange' in the 'empty' base case of loops (since +-- worker-wrapper requires (TODO: verify this) that all paths match +-- against the wrapped argument. +-- +-- Do not use ($), which has arity 1 since base-4.19. +-- See also https://gitlab.haskell.org/ghc/ghc/-/issues/23822 + +-- | Concatenate two 'Builder's. This function is only exported for use in rewriting +-- rules. Use 'mappend' otherwise. +{-# INLINE[1] append #-} +append :: Builder -> Builder -> Builder +append (Builder b1) (Builder b2) = Builder $ b1 . b2 + +stimesBuilder :: Integral t => t -> Builder -> Builder +{-# INLINABLE stimesBuilder #-} +stimesBuilder n b + | n >= 0 = go n + | otherwise = stimesNegativeErr + where go 0 = empty + go k = b `append` go (k - 1) + +stimesNegativeErr :: Builder +-- See Note [Float error calls out of INLINABLE things] +-- in Data.ByteString.Internal.Type +stimesNegativeErr + = errorWithoutStackTrace "stimes @Builder: non-negative multiplier expected" + +instance Semigroup Builder where + {-# INLINE (<>) #-} + (<>) = append + sconcat (b:|bs) = b <> foldr mappend mempty bs + {-# INLINE stimes #-} + stimes = stimesBuilder + +instance Monoid Builder where + {-# INLINE mempty #-} + mempty = empty + {-# INLINE mappend #-} + mappend = (<>) + {-# INLINE mconcat #-} + mconcat = foldr mappend mempty + +-- | For long or infinite lists use 'fromList' because it uses 'LazyByteString' otherwise use 'fromListN' which uses 'StrictByteString'. +instance IsList Builder where + type Item Builder = Word8 + fromList = lazyByteString . fromList + fromListN n = byteString . fromListN n + toList = toList . toLazyByteString + +-- | Flush the current buffer. This introduces a chunk boundary. +{-# INLINE flush #-} +flush :: Builder +flush = builder step + where + step k (BufferRange op _) = return $ insertChunk op S.empty k + + +------------------------------------------------------------------------------ +-- Put +------------------------------------------------------------------------------ + +-- | A 'Put' action denotes a computation of a value that writes a stream of +-- bytes as a side-effect. 'Put's are strict in their side-effect; i.e., the +-- stream of bytes will always be written before the computed value is +-- returned. +-- +-- 'Put's are a generalization of 'Builder's. The typical use case is the +-- implementation of an encoding that might fail (e.g., an interface to the +-- +-- compression library or the conversion from Base64 encoded data to +-- 8-bit data). For a 'Builder', the only way to handle and report such a +-- failure is ignore it or call 'error'. In contrast, 'Put' actions are +-- expressive enough to allow reporting and handling such a failure in a pure +-- fashion. +-- +-- @'Put' ()@ actions are isomorphic to 'Builder's. The functions 'putBuilder' +-- and 'fromPut' convert between these two types. Where possible, you should +-- use 'Builder's, as sequencing them is slightly cheaper than sequencing +-- 'Put's because they do not carry around a computed value. +newtype Put a = Put { unPut :: forall r. (a -> BuildStep r) -> BuildStep r } + +-- | Construct a 'Put' action. In contrast to 'BuildStep's, 'Put's are +-- referentially transparent in the sense that sequencing the same 'Put' +-- multiple times yields every time the same value with the same side-effect. +{-# INLINE put #-} +put :: (forall r. (a -> BuildStep r) -> BuildStep r) + -- ^ A function that fills a 'BufferRange', calls the continuation with + -- the updated 'BufferRange' and its computed value once its done, and + -- signals its caller how to proceed using 'done', 'bufferFull', or + -- 'insertChunk' signals. + -- + -- This function must be referentially transparent; i.e., calling it + -- multiple times with equally sized 'BufferRange's must result in the + -- same sequence of bytes being written and the same value being + -- computed. If you need mutable state, then you must allocate it anew + -- upon each call of this function. Moreover, this function must call + -- the continuation once its done. Otherwise, monadic sequencing of + -- 'Put's does not work. Finally, this function must write to all bytes + -- that it claims it has written. Otherwise, the resulting 'Put' is + -- not guaranteed to be referentially transparent and sensitive data + -- might leak. + -> Put a +put = Put + +-- | Run a 'Put'. +{-# INLINE runPut #-} +runPut :: Put a -- ^ Put to run + -> BuildStep a -- ^ 'BuildStep' that first writes the byte stream of + -- this 'Put' and then yields the computed value using + -- the 'done' signal. +runPut (Put p) = p $ \x (BufferRange op _) -> return $ Done op x + +instance Functor Put where + fmap f p = Put $ \k -> unPut p (k . f) + {-# INLINE fmap #-} + +-- | Synonym for '<*' from 'Applicative'; used in rewriting rules. +{-# INLINE[1] ap_l #-} +ap_l :: Put a -> Put b -> Put a +ap_l (Put a) (Put b) = Put $ \k -> a (\a' -> b (\_ -> k a')) + +-- | Synonym for '*>' from 'Applicative' and '>>' from 'Monad'; used in +-- rewriting rules. +{-# INLINE[1] ap_r #-} +ap_r :: Put a -> Put b -> Put b +ap_r (Put a) (Put b) = Put $ \k -> a (\_ -> b k) + +instance Applicative Put where + {-# INLINE pure #-} + pure x = Put $ \k -> k x + {-# INLINE (<*>) #-} + Put f <*> Put a = Put $ \k -> f (\f' -> a (k . f')) + {-# INLINE (<*) #-} + (<*) = ap_l + {-# INLINE (*>) #-} + (*>) = ap_r + +instance Monad Put where + {-# INLINE return #-} + return = pure + {-# INLINE (>>=) #-} + Put m >>= f = Put $ \k -> m (\m' -> unPut (f m') k) + {-# INLINE (>>) #-} + (>>) = (*>) + +-- Conversion between Put and Builder +------------------------------------- + +-- | Run a 'Builder' as a side-effect of a @'Put' ()@ action. +{-# INLINE[1] putBuilder #-} +putBuilder :: Builder -> Put () +putBuilder (Builder b) = Put $ \k -> b (k ()) + +-- | Convert a @'Put' ()@ action to a 'Builder'. +{-# INLINE fromPut #-} +fromPut :: Put () -> Builder +fromPut (Put p) = Builder $ \k -> p (const k) + +-- We rewrite consecutive uses of 'putBuilder' such that the append of the +-- involved 'Builder's is used. This can significantly improve performance, +-- when the bound-checks of the concatenated builders are fused. + +-- ap_l rules +{-# RULES + +"ap_l/putBuilder" forall b1 b2. + ap_l (putBuilder b1) (putBuilder b2) + = putBuilder (append b1 b2) + +"ap_l/putBuilder/assoc_r" forall b1 b2 (p :: Put a). + ap_l (putBuilder b1) (ap_l (putBuilder b2) p) + = ap_l (putBuilder (append b1 b2)) p + +"ap_l/putBuilder/assoc_l" forall (p :: Put a) b1 b2. + ap_l (ap_l p (putBuilder b1)) (putBuilder b2) + = ap_l p (putBuilder (append b1 b2)) + #-} + +-- ap_r rules +{-# RULES + +"ap_r/putBuilder" forall b1 b2. + ap_r (putBuilder b1) (putBuilder b2) + = putBuilder (append b1 b2) + +"ap_r/putBuilder/assoc_r" forall b1 b2 (p :: Put a). + ap_r (putBuilder b1) (ap_r (putBuilder b2) p) + = ap_r (putBuilder (append b1 b2)) p + +"ap_r/putBuilder/assoc_l" forall (p :: Put a) b1 b2. + ap_r (ap_r p (putBuilder b1)) (putBuilder b2) + = ap_r p (putBuilder (append b1 b2)) + + #-} + +-- combined ap_l/ap_r rules +{-# RULES + +"ap_l/ap_r/putBuilder/assoc_r" forall b1 b2 (p :: Put a). + ap_l (putBuilder b1) (ap_r (putBuilder b2) p) + = ap_l (putBuilder (append b1 b2)) p + +"ap_r/ap_l/putBuilder/assoc_r" forall b1 b2 (p :: Put a). + ap_r (putBuilder b1) (ap_l (putBuilder b2) p) + = ap_l (putBuilder (append b1 b2)) p + +"ap_l/ap_r/putBuilder/assoc_l" forall (p :: Put a) b1 b2. + ap_l (ap_r p (putBuilder b1)) (putBuilder b2) + = ap_r p (putBuilder (append b1 b2)) + +"ap_r/ap_l/putBuilder/assoc_l" forall (p :: Put a) b1 b2. + ap_r (ap_l p (putBuilder b1)) (putBuilder b2) + = ap_r p (putBuilder (append b1 b2)) + + #-} + + +-- Lifting IO actions +--------------------- + +{- +-- | Lift an 'IO' action to a 'Put' action. +{-# INLINE putLiftIO #-} +putLiftIO :: IO a -> Put a +putLiftIO io = put $ \k br -> io >>= (`k` br) +-} + + +------------------------------------------------------------------------------ +-- Executing a Put directly on a buffered Handle +------------------------------------------------------------------------------ + +-- | Run a 'Put' action redirecting the produced output to a 'Handle'. +-- +-- The output is buffered using the 'Handle's associated buffer. If this +-- buffer is too small to execute one step of the 'Put' action, then +-- it is replaced with a large enough buffer. +hPut :: forall a. Handle -> Put a -> IO a +hPut h p = do + fillHandle 1 (runPut p) + where + fillHandle :: Int -> BuildStep a -> IO a + fillHandle !minFree step = do + next <- wantWritableHandle "hPut" h fillHandle_ + next + where + -- | We need to return an inner IO action that is executed outside + -- the lock taken on the Handle for two reasons: + -- + -- 1. GHC.IO.Handle.Internals mentions in "Note [async]" that + -- we should never do any side-effecting operations before + -- an interruptible operation that may raise an async. exception + -- as long as we are inside 'wantWritableHandle' and the like. + -- We possibly run the interruptible 'flushWriteBuffer' right at + -- the start of 'fillHandle', hence entering it a second time is + -- not safe, as it could lead to a 'BuildStep' being run twice. + -- + -- FIXME (SM): Adapt this function or at least its documentation, + -- as it is OK to run a 'BuildStep' twice. We dropped this + -- requirement in favor of being able to use + -- 'unsafeDupablePerformIO' and the speed improvement that it + -- brings. + -- + -- 2. We use the 'S.hPut' function to also write to the handle. + -- This function tries to take the same lock taken by + -- 'wantWritableHandle'. Therefore, we cannot call 'S.hPut' + -- inside 'wantWritableHandle'. + -- + fillHandle_ :: Handle__ -> IO (IO a) + fillHandle_ h_ = do + makeSpace =<< readIORef refBuf + fillBuffer =<< readIORef refBuf + where + refBuf = haByteBuffer h_ + freeSpace buf = IO.bufSize buf - IO.bufR buf + + makeSpace buf + | IO.bufSize buf < minFree = do + flushWriteBuffer h_ + s <- IO.bufState <$> readIORef refBuf + IO.newByteBuffer minFree s >>= writeIORef refBuf + + | freeSpace buf < minFree = flushWriteBuffer h_ + | otherwise = + return () + + fillBuffer buf + | freeSpace buf < minFree = + error $ unlines + [ "Data.ByteString.Builder.Internal.hPut: internal error." + , " Not enough space after flush." + , " required: " ++ show minFree + , " free: " ++ show (freeSpace buf) + ] + | otherwise = do + let !br = BufferRange op (pBuf `plusPtr` IO.bufSize buf) + res <- fillWithBuildStep step doneH fullH insertChunkH br + touchForeignPtr fpBuf + return res + where + fpBuf = IO.bufRaw buf + pBuf = unsafeForeignPtrToPtr fpBuf + op = pBuf `plusPtr` IO.bufR buf + + {-# INLINE updateBufR #-} + updateBufR op' = do + let !off' = op' `minusPtr` pBuf + !buf' = buf {IO.bufR = off'} + writeIORef refBuf buf' + + doneH op' x = do + updateBufR op' + -- We must flush if this Handle is set to NoBuffering. + -- If it is set to LineBuffering, be conservative and + -- flush anyway (we didn't check for newlines in the data). + -- Flushing must happen outside this 'wantWriteableHandle' + -- due to the possible async. exception. + case haBufferMode h_ of + BlockBuffering _ -> return $ return x + _line_or_no_buffering -> return $ hFlush h >> return x + + fullH op' minSize nextStep = do + updateBufR op' + return $ fillHandle minSize nextStep + -- 'fillHandle' will flush the buffer (provided there is + -- really less than @minSize@ space left) before executing + -- the 'nextStep'. + + insertChunkH op' bs nextStep = do + updateBufR op' + return $ do + S.hPut h bs + fillHandle 1 nextStep + +-- | Execute a 'Put' and return the computed result and the bytes +-- written during the computation as a 'L.LazyByteString'. +-- +-- This function is strict in the computed result and lazy in the writing of +-- the bytes. For example, given +-- +-- @ +--infinitePut = sequence_ (repeat (putBuilder (word8 1))) >> return 0 +-- @ +-- +-- evaluating the expression +-- +-- @ +--fst $ putToLazyByteString infinitePut +-- @ +-- +-- does not terminate, while evaluating the expression +-- +-- @ +--L.head $ snd $ putToLazyByteString infinitePut +-- @ +-- +-- does terminate and yields the value @1 :: Word8@. +-- +-- An illustrative example for these strictness properties is the +-- implementation of Base64 decoding (). +-- +-- @ +--type DecodingState = ... +-- +--decodeBase64 :: 'S.StrictByteString' -> DecodingState -> 'Put' (Maybe DecodingState) +--decodeBase64 = ... +-- @ +-- +-- The above function takes a 'S.StrictByteString' supposed to represent +-- Base64 encoded data and the current decoding state. +-- It writes the decoded bytes as the side-effect of the 'Put' and returns the +-- new decoding state, if the decoding of all data in the 'S.StrictByteString' was +-- successful. The checking if the 'S.StrictByteString' represents Base64 +-- encoded data and the actual decoding are fused. This makes the common case, +-- where all data represents Base64 encoded data, more efficient. It also +-- implies that all data must be decoded before the final decoding +-- state can be returned. 'Put's are intended for implementing such fused +-- checking and decoding/encoding, which is reflected in their strictness +-- properties. +{-# NOINLINE putToLazyByteString #-} +putToLazyByteString + :: Put a -- ^ 'Put' to execute + -> (a, L.LazyByteString) -- ^ Result and 'L.LazyByteString' + -- written as its side-effect +putToLazyByteString = putToLazyByteStringWith + (safeStrategy L.smallChunkSize L.defaultChunkSize) (, L.Empty) + + +-- | Execute a 'Put' with a buffer-allocation strategy and a continuation. For +-- example, 'putToLazyByteString' is implemented as follows. +-- +-- @ +--putToLazyByteString = 'putToLazyByteStringWith' +-- ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') (\x -> (x, L.empty)) +-- @ +-- +{-# INLINE putToLazyByteStringWith #-} +putToLazyByteStringWith + :: AllocationStrategy + -- ^ Buffer allocation strategy to use + -> (a -> (b, L.LazyByteString)) + -- ^ Continuation to use for computing the final result and the tail of + -- its side-effect (the written bytes). + -> Put a + -- ^ 'Put' to execute + -> (b, L.LazyByteString) + -- ^ Resulting 'L.LazyByteString' +putToLazyByteStringWith strategy k p = + ciosToLazyByteString strategy k $ unsafeDupablePerformIO $ + buildStepToCIOS strategy (runPut p) + + + +------------------------------------------------------------------------------ +-- ByteString insertion / controlling chunk boundaries +------------------------------------------------------------------------------ + +-- Raw memory +------------- + +-- | @'ensureFree' n@ ensures that there are at least @n@ free bytes +-- for the following 'Builder'. +{-# INLINE ensureFree #-} +ensureFree :: Int -> Builder +ensureFree minFree = + builder step + where + step k br@(BufferRange op ope) + | ope `minusPtr` op < minFree = return $ bufferFull minFree op k + | otherwise = k br + +-- | Copy the bytes from a 'S.StrictByteString' into the output stream. +wrappedBytesCopyStep :: S.StrictByteString -- ^ Input 'S.StrictByteString'. + -> BuildStep a -> BuildStep a +-- See Note [byteStringCopyStep and wrappedBytesCopyStep] +wrappedBytesCopyStep bs0 k = + go bs0 + where + go !bs@(S.BS ifp inpRemaining) (BufferRange op ope) + | inpRemaining <= outRemaining = do + S.unsafeWithForeignPtr ifp $ \ip -> copyBytes op ip inpRemaining + let !br' = BufferRange (op `plusPtr` inpRemaining) ope + k br' + | otherwise = do + S.unsafeWithForeignPtr ifp $ \ip -> copyBytes op ip outRemaining + let !bs' = S.unsafeDrop outRemaining bs + return $ bufferFull 1 ope (go bs') + where + outRemaining = ope `minusPtr` op + + +-- Strict ByteStrings +------------------------------------------------------------------------------ + + +-- | Construct a 'Builder' that copies the 'S.StrictByteString's, if it is +-- smaller than the treshold, and inserts it directly otherwise. +-- +-- For example, @byteStringThreshold 1024@ copies 'S.StrictByteString's whose size +-- is less or equal to 1kb, and inserts them directly otherwise. This implies +-- that the average chunk-size of the generated 'L.LazyByteString' may be as +-- low as 513 bytes, as there could always be just a single byte between the +-- directly inserted 1025 byte, 'S.StrictByteString's. +-- +{-# INLINE byteStringThreshold #-} +byteStringThreshold :: Int -> S.StrictByteString -> Builder +byteStringThreshold maxCopySize = + \bs -> builder $ step bs + where + step bs@(S.BS _ len) k br@(BufferRange !op _) + | len <= maxCopySize = byteStringCopyStep bs k br + | otherwise = return $ insertChunk op bs k + +-- | Construct a 'Builder' that copies the 'S.StrictByteString'. +-- +-- Use this function to create 'Builder's from smallish (@<= 4kb@) +-- 'S.StrictByteString's or if you need to guarantee that the 'S.StrictByteString' is not +-- shared with the chunks generated by the 'Builder'. +-- +{-# INLINE byteStringCopy #-} +byteStringCopy :: S.StrictByteString -> Builder +byteStringCopy = \bs -> builder $ byteStringCopyStep bs + +{- +Note [byteStringCopyStep and wrappedBytesCopyStep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A Builder that copies the contents of an arbitrary ByteString needs a +recursive loop, since the bytes to be copied might not fit into the +first few chunk buffers provided by the driver. That loop is +implemented in 'wrappedBytesCopyStep'. But we also have a +non-recursive wrapper, 'byteStringCopyStep', which performs exactly +the first iteration of that loop, falling back to 'wrappedBytesCopyStep' +if a chunk boundary is reached before the entire ByteString is copied. + +This is very strange! Why do we do this? Perhaps mostly for +historical reasons. But sadly, changing this to use a single +recursive loop regresses the benchmark 'foldMap byteStringCopy' by +about 30% as of 2024, in one of two ways: + + 1. If the continuation 'k' is taken as an argument of the + inner copying loop, it remains an unknown function call. + So for each bytestring copied, that continuation must be + entered later via a gen-apply function, which incurs dozens + of cycles of extra overhead. + 2. If the continuation 'k' is lifted out of the inner copying + loop, it becomes a free variable. And after a bit of + inlining, there will be no unknown function call. But, if + the continuation function has any free variables, these + become free variables of the inner copying loop, which + prevent the loop from floating out. (In the actual + benchmark, the tail of the list of bytestrings to copy is + such a free variable of the continuation.) As a result, + the inner copying loop becomes a function closure object + rather than a top-level function. And that means a new + inner-copying-loop function-closure-object must be + allocated on the heap for every bytestring copied, which + is expensive. + + In theory, GHC's late-lambda-lifting pass can clean this up by + abstracting over the problematic free variables. But for some + unknown reason (perhaps a bug in ghc-9.10.1) this optimization + does not fire on the relevant benchmark code, even with a + sufficiently high value of -fstg-lift-lams-rec-args. + + + +Alternatively, it is possible to avoid recursion altogether by +requesting that the next chunk be large enough to accommodate the +entire remainder of the input when a chunk boundary is reached. +But: + * For very large ByteStrings, this may incur unwanted latency. + * Large next-chunk-size requests have caused breakage downstream + in the past. See also https://github.com/yesodweb/wai/issues/894 +-} + +{-# INLINE byteStringCopyStep #-} +byteStringCopyStep :: S.StrictByteString -> BuildStep a -> BuildStep a +-- See Note [byteStringCopyStep and wrappedBytesCopyStep] +byteStringCopyStep bs@(S.BS ifp isize) k br@(BufferRange op ope) + | isize <= osize = do + S.unsafeWithForeignPtr ifp $ \ip -> copyBytes op ip isize + k (BufferRange op' ope) + | otherwise = wrappedBytesCopyStep bs k br + where + osize = ope `minusPtr` op + op' = op `plusPtr` isize + +-- | Construct a 'Builder' that always inserts the 'S.StrictByteString' +-- directly as a chunk. +-- +-- This implies flushing the output buffer, even if it contains just +-- a single byte. You should therefore use 'byteStringInsert' only for large +-- (@> 8kb@) 'S.StrictByteString's. Otherwise, the generated chunks are too +-- fragmented to be processed efficiently afterwards. +-- +{-# INLINE byteStringInsert #-} +byteStringInsert :: S.StrictByteString -> Builder +byteStringInsert = + \bs -> builder $ \k (BufferRange op _) -> return $ insertChunk op bs k + +-- Short bytestrings +------------------------------------------------------------------------------ + +-- | Construct a 'Builder' that copies the 'SH.ShortByteString'. +-- +{-# INLINE shortByteString #-} +shortByteString :: Sh.ShortByteString -> Builder +shortByteString = \sbs -> builder $ shortByteStringCopyStep sbs + +-- | Copy the bytes from a 'SH.ShortByteString' into the output stream. +{-# INLINE shortByteStringCopyStep #-} +shortByteStringCopyStep :: Sh.ShortByteString -- ^ Input 'SH.ShortByteString'. + -> BuildStep a -> BuildStep a +shortByteStringCopyStep !sbs k = + go 0 (Sh.length sbs) + where + go !ip !ipe (BufferRange op ope) + | inpRemaining <= outRemaining = do + Sh.copyToPtr sbs ip op inpRemaining + let !br' = BufferRange (op `plusPtr` inpRemaining) ope + k br' + | otherwise = do + Sh.copyToPtr sbs ip op outRemaining + let !ip' = ip + outRemaining + return $ bufferFull 1 ope (go ip' ipe) + where + outRemaining = ope `minusPtr` op + inpRemaining = ipe - ip + + +-- Lazy bytestrings +------------------------------------------------------------------------------ + +-- | Construct a 'Builder' that uses the thresholding strategy of 'byteStringThreshold' +-- for each chunk of the 'L.LazyByteString'. +-- +{-# INLINE lazyByteStringThreshold #-} +lazyByteStringThreshold :: Int -> L.LazyByteString -> Builder +lazyByteStringThreshold maxCopySize = + L.foldrChunks (\bs b -> byteStringThreshold maxCopySize bs `mappend` b) mempty + -- TODO: We could do better here. Currently, Large, Small, Large, leads to + -- an unnecessary copy of the 'Small' chunk. + +-- | Construct a 'Builder' that copies the 'L.LazyByteString'. +-- +{-# INLINE lazyByteStringCopy #-} +lazyByteStringCopy :: L.LazyByteString -> Builder +lazyByteStringCopy = + L.foldrChunks (\bs b -> byteStringCopy bs `mappend` b) mempty + +-- | Construct a 'Builder' that inserts all chunks of the 'L.LazyByteString' +-- directly. +-- +{-# INLINE lazyByteStringInsert #-} +lazyByteStringInsert :: L.LazyByteString -> Builder +lazyByteStringInsert = + L.foldrChunks (\bs b -> byteStringInsert bs `mappend` b) mempty + +-- | Create a 'Builder' denoting the same sequence of bytes as a +-- 'S.StrictByteString'. +-- The 'Builder' inserts large 'S.StrictByteString's directly, but copies small ones +-- to ensure that the generated chunks are large on average. +-- +{-# INLINE byteString #-} +byteString :: S.StrictByteString -> Builder +byteString = byteStringThreshold maximalCopySize + +-- | Create a 'Builder' denoting the same sequence of bytes as a lazy +-- 'L.LazyByteString'. +-- The 'Builder' inserts large chunks of the 'L.LazyByteString' directly, +-- but copies small ones to ensure that the generated chunks are large on +-- average. +-- +{-# INLINE lazyByteString #-} +lazyByteString :: L.LazyByteString -> Builder +lazyByteString = lazyByteStringThreshold maximalCopySize +-- FIXME: also insert the small chunk for [large,small,large] directly. +-- Perhaps it makes even sense to concatenate the small chunks in +-- [large,small,small,small,large] and insert them directly afterwards to avoid +-- unnecessary buffer spilling. Hmm, but that uncontrollably increases latency +-- => no good! + +-- | The maximal size of a 'S.StrictByteString' that is copied. +-- @2 * 'L.smallChunkSize'@ to guarantee that on average a chunk is of +-- 'L.smallChunkSize'. +maximalCopySize :: Int +maximalCopySize = 2 * L.smallChunkSize + +------------------------------------------------------------------------------ +-- Builder execution +------------------------------------------------------------------------------ + +-- | A buffer allocation strategy for executing 'Builder's. +data AllocationStrategy = AllocationStrategy + (Maybe (Buffer, Int) -> IO Buffer) + {-# UNPACK #-} !Int + (Int -> Int -> Bool) + +-- | Create a custom allocation strategy. See the code for 'safeStrategy' and +-- 'untrimmedStrategy' for examples. +{-# INLINE customStrategy #-} +customStrategy + :: (Maybe (Buffer, Int) -> IO Buffer) + -- ^ Buffer allocation function. + -- + -- * If 'Nothing' is given, then a new first buffer should be allocated. + -- + -- * If @'Just' (oldBuf, minSize)@ is given, then a buffer with minimal + -- size @minSize@ must be returned. The strategy may reuse @oldBuf@ only if + -- @oldBuf@ is large enough and the consumer can guarantee that this will + -- not result in a violation of referential transparency. + -- + -- /Warning:/ for multithreaded programs, it is generally unsafe to reuse + -- buffers when using the consumers of 'Builder' in this package. For + -- example, if 'toLazyByteStringWith' is called with an + -- 'AllocationStrategy' that reuses buffers, evaluating the result by + -- multiple threads simultaneously may lead to corrupted output. + -> Int + -- ^ Default buffer size. + -> (Int -> Int -> Bool) + -- ^ A predicate @trim used allocated@ returning 'True', if the buffer + -- should be trimmed before it is returned. + -> AllocationStrategy +customStrategy = AllocationStrategy + +-- | Sanitize a buffer size; i.e., make it at least the size of an 'Int'. +{-# INLINE sanitize #-} +sanitize :: Int -> Int +sanitize = max (sizeOf (undefined :: Int)) + +-- | Use this strategy for generating 'L.LazyByteString's whose chunks are +-- discarded right after they are generated. For example, if you just generate +-- them to write them to a network socket. +{-# INLINE untrimmedStrategy #-} +untrimmedStrategy :: Int -- ^ Size of the first buffer + -> Int -- ^ Size of successive buffers + -> AllocationStrategy + -- ^ An allocation strategy that does not trim any of the + -- filled buffers before converting it to a chunk +untrimmedStrategy firstSize bufSize = + AllocationStrategy nextBuffer (sanitize bufSize) (\_ _ -> False) + where + {-# INLINE nextBuffer #-} + nextBuffer Nothing = newBuffer $ sanitize firstSize + nextBuffer (Just (_, minSize)) = newBuffer minSize + + +-- | Use this strategy for generating 'L.LazyByteString's whose chunks are +-- likely to survive one garbage collection. This strategy trims buffers +-- that are filled less than half in order to avoid spilling too much memory. +{-# INLINE safeStrategy #-} +safeStrategy :: Int -- ^ Size of first buffer + -> Int -- ^ Size of successive buffers + -> AllocationStrategy + -- ^ An allocation strategy that guarantees that at least half + -- of the allocated memory is used for live data +safeStrategy firstSize bufSize = + AllocationStrategy nextBuffer (sanitize bufSize) trim + where + trim used size = 2 * used < size + {-# INLINE nextBuffer #-} + nextBuffer Nothing = newBuffer $ sanitize firstSize + nextBuffer (Just (_, minSize)) = newBuffer minSize + +-- | Execute a 'Builder' and return the generated chunks as a 'L.LazyByteString'. +-- The work is performed lazy, i.e., only when a chunk of the 'L.LazyByteString' +-- is forced. +{-# NOINLINE toLazyByteString #-} -- ensure code is shared +toLazyByteString :: Builder -> L.LazyByteString +toLazyByteString = toLazyByteStringWith + (safeStrategy L.smallChunkSize L.defaultChunkSize) L.Empty + +-- | /Heavy inlining./ Execute a 'Builder' with custom execution parameters. +-- +-- This function is inlined despite its heavy code-size to allow fusing with +-- the allocation strategy. For example, the default 'Builder' execution +-- function 'Data.ByteString.Builder.Internal.toLazyByteString' is defined as follows. +-- +-- @ +-- {-\# NOINLINE toLazyByteString \#-} +-- toLazyByteString = +-- toLazyByteStringWith ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') L.Empty +-- @ +-- +-- where @L.Empty@ is the zero-length 'L.LazyByteString'. +-- +-- In most cases, the parameters used by 'Data.ByteString.Builder.toLazyByteString' give good +-- performance. A sub-performing case of 'Data.ByteString.Builder.toLazyByteString' is executing short +-- (<128 bytes) 'Builder's. In this case, the allocation overhead for the first +-- 4kb buffer and the trimming cost dominate the cost of executing the +-- 'Builder'. You can avoid this problem using +-- +-- >toLazyByteStringWith (safeStrategy 128 smallChunkSize) L.Empty +-- +-- This reduces the allocation and trimming overhead, as all generated +-- 'L.LazyByteString's fit into the first buffer and there is no trimming +-- required, if more than 64 bytes and less than 128 bytes are written. +-- +{-# INLINE toLazyByteStringWith #-} +toLazyByteStringWith + :: AllocationStrategy + -- ^ Buffer allocation strategy to use + -> L.LazyByteString + -- ^ 'L.LazyByteString' to use as the tail of the generated lazy + -- 'L.LazyByteString' + -> Builder + -- ^ 'Builder' to execute + -> L.LazyByteString + -- ^ Resulting 'L.LazyByteString' +toLazyByteStringWith strategy k b = + ciosUnitToLazyByteString strategy k $ unsafeDupablePerformIO $ + buildStepToCIOS strategy (runBuilder b) + +-- | Convert a 'BuildStep' to a 'ChunkIOStream' stream by executing it on +-- 'Buffer's allocated according to the given 'AllocationStrategy'. +{-# INLINE buildStepToCIOS #-} +buildStepToCIOS + :: forall a. + AllocationStrategy -- ^ Buffer allocation strategy to use + -> BuildStep a -- ^ 'BuildStep' to execute + -> IO (ChunkIOStream a) +buildStepToCIOS (AllocationStrategy nextBuffer bufSize trim) = + \step -> nextBuffer Nothing >>= fill step + where + fill :: BuildStep a -> Buffer -> IO (ChunkIOStream a) + fill !step buf@(Buffer fpbuf br@(BufferRange _ pe)) = do + res <- fillWithBuildStep step doneH fullH insertChunkH br + touchForeignPtr fpbuf + return res + where + pbuf :: Ptr Word8 + pbuf = unsafeForeignPtrToPtr fpbuf + + doneH :: Ptr Word8 -> a -> IO (ChunkIOStream a) + doneH op' x = return $ + Finished (Buffer fpbuf (BufferRange op' pe)) x + + fullH :: Ptr Word8 -> Int -> BuildStep a -> IO (ChunkIOStream a) + fullH op' minSize nextStep = + wrapChunk op' $ const $ + nextBuffer (Just (buf, max minSize bufSize)) >>= fill nextStep + + insertChunkH :: Ptr Word8 -> S.StrictByteString -> BuildStep a -> IO (ChunkIOStream a) + insertChunkH op' bs nextStep = + wrapChunk op' $ \isEmpty -> yield1 bs $ + -- Checking for empty case avoids allocating 'n-1' empty + -- buffers for 'n' insertChunkH right after each other. + if isEmpty + then fill nextStep buf + else do buf' <- nextBuffer (Just (buf, bufSize)) + fill nextStep buf' + + -- Wrap and yield a chunk, trimming it if necesary + {-# INLINE wrapChunk #-} + wrapChunk :: Ptr Word8 -> (Bool -> IO (ChunkIOStream a)) -> IO (ChunkIOStream a) + wrapChunk !op' mkCIOS + | chunkSize == 0 = mkCIOS True + | trim chunkSize size = do + bs <- S.createFp chunkSize $ \fpbuf' -> + S.memcpyFp fpbuf' fpbuf chunkSize + -- It is not safe to re-use the old buffer (see #690), + -- so we allocate a new buffer after trimming. + return $ Yield1 bs (mkCIOS False) + | otherwise = + return $ Yield1 (S.BS fpbuf chunkSize) (mkCIOS False) + where + chunkSize = op' `minusPtr` pbuf + size = pe `minusPtr` pbuf diff --git a/Data/ByteString/Builder/Prim.hs b/Data/ByteString/Builder/Prim.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Prim.hs @@ -0,0 +1,778 @@ +{-# LANGUAGE Trustworthy #-} + +{- | Copyright : (c) 2010-2011 Simon Meier + (c) 2010 Jasper van der Jeugt +License : BSD3-style (see LICENSE) +Maintainer : Simon Meier +Portability : GHC + +This module provides 'Builder' /primitives/, which are lower level building +blocks for constructing 'Builder's. You don't need to go down to this level but +it can be slightly faster. + +Morally, builder primitives are like functions @a -> Builder@, that is they +take a value and encode it as a sequence of bytes, represented as a 'Builder'. +Of course their implementation is a bit more specialised. + +Builder primitives come in two forms: fixed-size and bounded-size. + +* /Fixed(-size) primitives/ are builder primitives that always result in a + sequence of bytes of a fixed length. That is, the length is independent of + the value that is encoded. An example of a fixed size primitive is the + big-endian encoding of a 'Word64', which always results in exactly 8 bytes. + +* /Bounded(-size) primitives/ are builder primitives that always result in a + sequence of bytes that is no larger than a predetermined bound. That is, the + bound is independent of the value that is encoded but the actual length will + depend on the value. An example for a bounded primitive is the UTF-8 encoding + of a 'Char', which can be 1,2,3 or 4 bytes long, so the bound is 4 bytes. + +Note that fixed primitives can be considered as a special case of bounded +primitives, and we can lift from fixed to bounded. + +Because bounded primitives are the more general case, in this documentation we +only refer to fixed size primitives where it matters that the resulting +sequence of bytes is of a fixed length. Otherwise, we just refer to bounded +size primitives. + +The purpose of using builder primitives is to improve the performance of +'Builder's. These improvements stem from making the two most common steps +performed by a 'Builder' more efficient. We explain these two steps in turn. + +The first most common step is the concatenation of two 'Builder's. Internally, +concatenation corresponds to function composition. (Note that 'Builder's can +be seen as difference-lists of buffer-filling functions; cf. +. ) +Function composition is a fast /O(1)/ operation. However, we can use bounded +primitives to remove some of these function compositions altogether, which is +more efficient. + +The second most common step performed by a 'Builder' is to fill a buffer using +a bounded primitives, which works as follows. The 'Builder' checks whether +there is enough space left to execute the bounded primitive. If there is, then +the 'Builder' executes the bounded primitive and calls the next 'Builder' with +the updated buffer. Otherwise, the 'Builder' signals its driver that it +requires a new buffer. This buffer must be at least as large as the bound of +the primitive. We can use bounded primitives to reduce the number of +buffer-free checks by fusing the buffer-free checks of consecutive 'Builder's. +We can also use bounded primitives to simplify the control flow for signalling +that a buffer is full by ensuring that we check first that there is enough +space left and only then decide on how to encode a given value. + +Let us illustrate these improvements on the CSV-table rendering example from +"Data.ByteString.Builder". Its \"hot code\" is the rendering of a table's +cells, which we implement as follows using only the functions from the +'Builder' API. + +@ +import "Data.ByteString.Builder" as B + +renderCell :: Cell -> Builder +renderCell (StringC cs) = renderString cs +renderCell (IntC i) = B.intDec i + +renderString :: String -> Builder +renderString cs = B.charUtf8 \'\"\' \<\> foldMap escape cs \<\> B.charUtf8 \'\"\' + where + escape \'\\\\\' = B.charUtf8 \'\\\\\' \<\> B.charUtf8 \'\\\\\' + escape \'\\\"\' = B.charUtf8 \'\\\\\' \<\> B.charUtf8 \'\\\"\' + escape c = B.charUtf8 c +@ + +Efficient encoding of 'Int's as decimal numbers is performed by @intDec@. +Optimization potential exists for the escaping of 'String's. The above +implementation has two optimization opportunities. First, the buffer-free +checks of the 'Builder's for escaping double quotes and backslashes can be +fused. Second, the concatenations performed by 'foldMap' can be eliminated. +The following implementation exploits these optimizations. + +@ +import qualified Data.ByteString.Builder.Prim as P +import Data.ByteString.Builder.Prim + ( 'condB', 'liftFixedToBounded', ('>*<'), ('>$<') ) + +renderString :: String -\> Builder +renderString cs = + B.charUtf8 \'\"\' \<\> 'P.primMapListBounded' escape cs \<\> B.charUtf8 \'\"\' + where + escape :: 'P.BoundedPrim' Char + escape = + 'condB' (== \'\\\\\') (fixed2 (\'\\\\\', \'\\\\\')) $ + 'condB' (== \'\\\"\') (fixed2 (\'\\\\\', \'\\\"\')) $ + 'charUtf8' +   + {-\# INLINE fixed2 \#-} + fixed2 x = 'P.liftFixedToBounded' $ const x '>$<' 'P.char7' '>*<' 'P.char7' +@ + +The code should be mostly self-explanatory. The slightly awkward syntax is +because the combinators are written such that the size-bound of the resulting +'BoundedPrim' can be computed at compile time. We also explicitly inline the +@fixed2@ primitive, which encodes a fixed tuple of characters, to ensure that +the bound computation happens at compile time. When encoding the following list +of 'String's, the optimized implementation of @renderString@ is two times +faster. + +@ +maxiStrings :: [String] +maxiStrings = take 1000 $ cycle [\"hello\", \"\\\"1\\\"\", \"λ-wörld\"] +@ + +Most of the performance gain stems from using 'primMapListBounded', which +encodes a list of values from left-to-right with a 'BoundedPrim'. It exploits +the 'Builder' internals to avoid unnecessary function compositions (i.e., +concatenations). In the future, we might expect the compiler to perform the +optimizations implemented in 'primMapListBounded'. However, it seems that the +code is currently to complicated for the compiler to see through. Therefore, we +provide the 'BoundedPrim' escape hatch, which allows data structures to provide +very efficient encoding traversals, like 'primMapListBounded' for lists. + +Note that 'BoundedPrim's are a bit verbose, but quite versatile. Here is an +example of a 'BoundedPrim' for combined HTML escaping and UTF-8 encoding. It +exploits that the escaped character with the maximal Unicode codepoint is \'>\'. + +@ +{-\# INLINE charUtf8HtmlEscaped \#-} +charUtf8HtmlEscaped :: 'BoundedPrim' Char +charUtf8HtmlEscaped = + 'condB' (> \'\>\' ) 'charUtf8' $ + 'condB' (== \'\<\' ) (fixed4 (\'&\',(\'l\',(\'t\',\';\')))) $ -- < + 'condB' (== \'\>\' ) (fixed4 (\'&\',(\'g\',(\'t\',\';\')))) $ -- > + 'condB' (== \'&\' ) (fixed5 (\'&\',(\'a\',(\'m\',(\'p\',\';\'))))) $ -- & + 'condB' (== \'\"\' ) (fixed5 (\'&\',(\'\#\',(\'3\',(\'4\',\';\'))))) $ -- &\#34; + 'condB' (== \'\\\'\') (fixed5 (\'&\',(\'\#\',(\'3\',(\'9\',\';\'))))) $ -- &\#39; + ('liftFixedToBounded' 'char7') -- fallback for 'Char's smaller than \'\>\' + where + {-\# INLINE fixed4 \#-} + fixed4 x = 'liftFixedToBounded' $ const x '>$<' + char7 '>*<' char7 '>*<' char7 '>*<' char7 +   + {-\# INLINE fixed5 \#-} + fixed5 x = 'liftFixedToBounded' $ const x '>$<' + char7 '>*<' char7 '>*<' char7 '>*<' char7 '>*<' char7 +@ + +This module currently does not expose functions that require the special +properties of fixed-size primitives. They are useful for prefixing 'Builder's +with their size or for implementing chunked encodings. We will expose the +corresponding functions in future releases of this library. +-} + + + +{- +-- +-- +-- A /bounded primitive/ is a builder primitive that never results in a sequence +-- longer than some fixed number of bytes. This number of bytes must be +-- independent of the value being encoded. Typical examples of bounded +-- primitives are the big-endian encoding of a 'Word64', which results always +-- in exactly 8 bytes, or the UTF-8 encoding of a 'Char', which results always +-- in less or equal to 4 bytes. +-- +-- Typically, primitives are implemented efficiently by allocating a buffer (an +-- array of bytes) and repeatedly executing the following two steps: (1) +-- writing to the buffer until it is full and (2) handing over the filled part +-- to the consumer of the encoded value. Step (1) is where bounded primitives +-- are used. We must use a bounded primitive, as we must check that there is +-- enough free space /before/ actually writing to the buffer. +-- +-- In term of expressiveness, it would be sufficient to construct all encodings +-- from the single bounded encoding that encodes a 'Word8' as-is. However, +-- this is not sufficient in terms of efficiency. It results in unnecessary +-- buffer-full checks and it complicates the program-flow for writing to the +-- buffer, as buffer-full checks are interleaved with analysing the value to be +-- encoded (e.g., think about the program-flow for UTF-8 encoding). This has a +-- significant effect on overall encoding performance, as encoding primitive +-- Haskell values such as 'Word8's or 'Char's lies at the heart of every +-- encoding implementation. +-- +-- The bounded 'Encoding's provided by this module remove this performance +-- problem. Intuitively, they consist of a tuple of the bound on the maximal +-- number of bytes written and the actual implementation of the encoding as a +-- function that modifies a mutable buffer. Hence when executing a bounded +-- 'Encoding', the buffer-full check can be done once before the actual writing +-- to the buffer. The provided 'Encoding's also take care to implement the +-- actual writing to the buffer efficiently. Moreover, combinators are +-- provided to construct new bounded encodings from the provided ones. +-- +-- A typical example for using the combinators is a bounded 'Encoding' that +-- combines escaping the ' and \\ characters with UTF-8 encoding. More +-- precisely, the escaping to be done is the one implemented by the following +-- @escape@ function. +-- +-- > escape :: Char -> [Char] +-- > escape '\'' = "\\'" +-- > escape '\\' = "\\\\" +-- > escape c = [c] +-- +-- The bounded 'Encoding' that combines this escaping with UTF-8 encoding is +-- the following. +-- +-- > import Data.ByteString.Builder.Prim.Utf8 (char) +-- > +-- > {-# INLINE escapeChar #-} +-- > escapeUtf8 :: BoundedPrim Char +-- > escapeUtf8 = +-- > encodeIf ('\'' ==) (char <#> char #. const ('\\','\'')) $ +-- > encodeIf ('\\' ==) (char <#> char #. const ('\\','\\')) $ +-- > char +-- +-- The definition of 'escapeUtf8' is more complicated than 'escape', because +-- the combinators ('encodeIf', 'encodePair', '#.', and 'char') used in +-- 'escapeChar' compute both the bound on the maximal number of bytes written +-- (8 for 'escapeUtf8') as well as the low-level buffer manipulation required +-- to implement the encoding. Bounded 'Encoding's should always be inlined. +-- Otherwise, the compiler cannot compute the bound on the maximal number of +-- bytes written at compile-time. Without inlinining, it would also fail to +-- optimize the constant encoding of the escape characters in the above +-- example. Functions that execute bounded 'Encoding's also perform +-- suboptimally, if the definition of the bounded 'Encoding' is not inlined. +-- Therefore we add an 'INLINE' pragma to 'escapeUtf8'. +-- +-- Currently, the only library that executes bounded 'Encoding's is the +-- 'bytestring' library (). It +-- uses bounded 'Encoding's to implement most of its lazy bytestring builders. +-- Executing a bounded encoding should be done using the corresponding +-- functions in the lazy bytestring builder 'Extras' module. +-- +-- TODO: Merge with explanation/example below +-- +-- Bounded 'E.Encoding's abstract encodings of Haskell values that can be implemented by +-- writing a bounded-size sequence of bytes directly to memory. They are +-- lifted to conversions from Haskell values to 'Builder's by wrapping them +-- with a bound-check. The compiler can implement this bound-check very +-- efficiently (i.e, a single comparison of the difference of two pointers to a +-- constant), because the bound of a 'E.Encoding' is always independent of the +-- value being encoded and, in most cases, a literal constant. +-- +-- 'E.Encoding's are the primary means for defining conversion functions from +-- primitive Haskell values to 'Builder's. Most 'Builder' constructors +-- provided by this library are implemented that way. +-- 'E.Encoding's are also used to construct conversions that exploit the internal +-- representation of data-structures. +-- +-- For example, 'encodeByteStringWith' works directly on the underlying byte +-- array and uses some tricks to reduce the number of variables in its inner +-- loop. Its efficiency is exploited for implementing the @filter@ and @map@ +-- functions in "Data.ByteString.Lazy" as +-- +-- > import qualified Codec.Bounded.Encoding as E +-- > +-- > filter :: (Word8 -> Bool) -> ByteString -> ByteString +-- > filter p = toLazyByteString . encodeLazyByteStringWithB write +-- > where +-- > write = E.encodeIf p E.word8 E.emptyEncoding +-- > +-- > map :: (Word8 -> Word8) -> ByteString -> ByteString +-- > map f = toLazyByteString . encodeLazyByteStringWithB (E.word8 E.#. f) +-- +-- Compared to earlier versions of @filter@ and @map@ on 'L.LazyByteString's, +-- these versions use a more efficient inner loop and have the additional +-- advantage that they always result in well-chunked 'L.LazyByteString's; i.e, they +-- also perform automatic defragmentation. +-- +-- We can also use 'E.Encoding's to improve the efficiency of the following +-- 'renderString' function from our UTF-8 CSV table encoding example in +-- "Data.ByteString.Builder". +-- +-- > renderString :: String -> Builder +-- > renderString cs = charUtf8 '"' <> foldMap escape cs <> charUtf8 '"' +-- > where +-- > escape '\\' = charUtf8 '\\' <> charUtf8 '\\' +-- > escape '\"' = charUtf8 '\\' <> charUtf8 '\"' +-- > escape c = charUtf8 c +-- +-- The idea is to save on 'mappend's by implementing a 'E.Encoding' that escapes +-- characters and using 'encodeListWith', which implements writing a list of +-- values with a tighter inner loop and no 'mappend'. +-- +-- > import Data.ByteString.Builder.Extra -- assume these +-- > import Data.ByteString.Builder.Prim -- imports are present +-- > ( BoundedPrim, encodeIf, (<#>), (#.) ) +-- > import Data.ByteString.Builder.Prim.Utf8 (char) +-- > +-- > renderString :: String -> Builder +-- > renderString cs = +-- > charUtf8 '"' <> primMapListBounded escapedUtf8 cs <> charUtf8 '"' +-- > where +-- > escapedUtf8 :: BoundedPrim Char +-- > escapedUtf8 = +-- > encodeIf (== '\\') (char <#> char #. const ('\\', '\\')) $ +-- > encodeIf (== '\"') (char <#> char #. const ('\\', '\"')) $ +-- > char +-- +-- This 'Builder' considers a buffer with less than 8 free bytes as full. As +-- all functions are inlined, the compiler is able to optimize the constant +-- 'E.Encoding's as two sequential 'poke's. Compared to the first implementation of +-- 'renderString' this implementation is 1.7x faster. +-- +-} +{- +Internally, 'Builder's are buffer-fill operations that are +given a continuation buffer-fill operation and a buffer-range to be filled. +A 'Builder' first checks if the buffer-range is large enough. If that's +the case, the 'Builder' writes the sequences of bytes to the buffer and +calls its continuation. Otherwise, it returns a signal that it requires a +new buffer together with a continuation to be called on this new buffer. +Ignoring the rare case of a full buffer-range, the execution cost of a +'Builder' consists of three parts: + + 1. The time taken to read the parameters; i.e., the buffer-fill + operation to call after the 'Builder' is done and the buffer-range to + fill. + + 2. The time taken to check for the size of the buffer-range. + + 3. The time taken for the actual encoding. + +We can reduce cost (1) by ensuring that fewer buffer-fill function calls are +required. We can reduce cost (2) by fusing buffer-size checks of sequential +writes. For example, when escaping a 'String' using 'renderString', it would +be sufficient to check before encoding a character that at least 8 bytes are +free. We can reduce cost (3) by implementing better primitive 'Builder's. +For example, 'renderCell' builds an intermediate list containing the decimal +representation of an 'Int'. Implementing a direct decimal encoding of 'Int's +to memory would be more efficient, as it requires fewer buffer-size checks +and less allocation. It is also a planned extension of this library. + +The first two cost reductions are supported for user code through functions +in "Data.ByteString.Builder.Extra". There, we continue the above example +and drop the generation time to 0.8ms by implementing 'renderString' more +cleverly. The third reduction requires meddling with the internals of +'Builder's and is not recommended in code outside of this library. However, +patches to this library are very welcome. +-} +module Data.ByteString.Builder.Prim ( + + -- * Bounded-size primitives + + BoundedPrim + + -- ** Combinators + -- | The combinators for 'BoundedPrim's are implemented such that the + -- size of the resulting 'BoundedPrim' can be computed at compile time. + , emptyB + , (>*<) + , (>$<) + , eitherB + , condB + + -- ** Builder construction + , primBounded + , primMapListBounded + , primUnfoldrBounded + + , primMapByteStringBounded + , primMapLazyByteStringBounded + + -- * Fixed-size primitives + , FixedPrim + + -- ** Combinators + -- | The combinators for 'FixedPrim's are implemented such that the + -- 'Data.ByteString.Builder.Prim.size' + -- of the resulting 'FixedPrim' is computed at compile time. + -- + -- The '(>*<)' and '(>$<)' pairing and mapping operators can be used + -- with 'FixedPrim'. + , emptyF + , liftFixedToBounded + + -- ** Builder construction + -- | In terms of expressivity, the function 'fixedPrim' would be sufficient + -- for constructing 'Builder's from 'FixedPrim's. The fused variants of + -- this function are provided because they allow for more efficient + -- implementations. Our compilers are just not smart enough yet; and for some + -- of the employed optimizations (see the code of 'primMapByteStringFixed') + -- they will very likely never be. + -- + -- Note that functions marked with \"/Heavy inlining./\" are forced to be + -- inlined because they must be specialized for concrete encodings, + -- but are rather heavy in terms of code size. We recommend to define a + -- top-level function for every concrete instantiation of such a function in + -- order to share its code. A typical example is the function + -- 'Data.ByteString.Builder.byteStringHex' from "Data.ByteString.Builder.ASCII", + -- which is implemented as follows. + -- + -- @ + -- byteStringHex :: S.StrictByteString -> Builder + -- byteStringHex = 'primMapByteStringFixed' 'word8HexFixed' + -- @ + -- + , primFixed + , primMapListFixed + , primUnfoldrFixed + + , primMapByteStringFixed + , primMapLazyByteStringFixed + + -- * Standard encodings of Haskell values + + , module Data.ByteString.Builder.Prim.Binary + + -- ** Character encodings + , module Data.ByteString.Builder.Prim.ASCII + + -- *** ISO/IEC 8859-1 (Char8) + -- | The ISO/IEC 8859-1 encoding is an 8-bit encoding often known as Latin-1. + -- The /Char8/ encoding implemented here works by truncating the Unicode + -- codepoint to 8-bits and encoding them as a single byte. For the codepoints + -- 0-255 this corresponds to the ISO/IEC 8859-1 encoding. Note that the + -- Char8 encoding is equivalent to the ASCII encoding on the Unicode + -- codepoints 0-127. Hence, functions such as 'intDec' can also be used for + -- encoding 'Int's as a decimal number with Char8 encoded characters. + , char8 + + -- *** UTF-8 + -- | The UTF-8 encoding can encode all Unicode codepoints. + -- It is equivalent to the ASCII encoding on the Unicode codepoints 0-127. + -- Hence, functions such as 'intDec' can also be used for encoding 'Int's as + -- a decimal number with UTF-8 encoded characters. + , charUtf8 + + , cstring + , cstringUtf8 + +{- + -- * Testing support + -- | The following four functions are intended for testing use + -- only. They are /not/ efficient. Basic encodings are efficiently executed by + -- creating 'Builder's from them using the @encodeXXX@ functions explained at + -- the top of this module. + + , evalF + , evalB + + , showF + , showB +-} + ) where + +import Data.ByteString.Builder.Internal + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L + +import Data.Char (ord) + +import Data.ByteString.Builder.Prim.Internal hiding (size, sizeBound) +import qualified Data.ByteString.Builder.Prim.Internal as I +import Data.ByteString.Builder.Prim.Binary +import Data.ByteString.Builder.Prim.ASCII + +import Foreign +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import GHC.Word (Word8 (..)) +import GHC.Exts +import GHC.IO + +------------------------------------------------------------------------------ +-- Creating Builders from bounded primitives +------------------------------------------------------------------------------ + +-- | Encode a value with a 'FixedPrim'. +{-# INLINE primFixed #-} +primFixed :: FixedPrim a -> (a -> Builder) +primFixed = primBounded . toB + +-- | Encode a list of values from left-to-right with a 'FixedPrim'. +{-# INLINE primMapListFixed #-} +primMapListFixed :: FixedPrim a -> ([a] -> Builder) +primMapListFixed = primMapListBounded . toB + +-- | Encode a list of values represented as an 'Data.List.unfoldr' with a 'FixedPrim'. +{-# INLINE primUnfoldrFixed #-} +primUnfoldrFixed :: FixedPrim b -> (a -> Maybe (b, a)) -> a -> Builder +primUnfoldrFixed = primUnfoldrBounded . toB + +-- | /Heavy inlining./ Encode all bytes of a 'S.StrictByteString' from +-- left-to-right with a 'FixedPrim'. This function is quite versatile. For +-- example, we can use it to construct a 'Builder' that maps every byte before +-- copying it to the buffer to be filled. +-- +-- > mapToBuilder :: (Word8 -> Word8) -> S.StrictByteString -> Builder +-- > mapToBuilder f = primMapByteStringFixed (contramapF f word8) +-- +-- We can also use it to hex-encode a 'S.StrictByteString' as shown by the +-- 'Data.ByteString.Builder.ASCII.byteStringHex' example above. +{-# INLINE primMapByteStringFixed #-} +primMapByteStringFixed :: FixedPrim Word8 -> (S.StrictByteString -> Builder) +primMapByteStringFixed = primMapByteStringBounded . toB + +-- | /Heavy inlining./ Encode all bytes of a 'L.LazyByteString' from +-- left-to-right with a 'FixedPrim'. +{-# INLINE primMapLazyByteStringFixed #-} +primMapLazyByteStringFixed :: FixedPrim Word8 -> (L.LazyByteString -> Builder) +primMapLazyByteStringFixed = primMapLazyByteStringBounded . toB + +-- IMPLEMENTATION NOTE: Sadly, 'encodeListWith' cannot be used for foldr/build +-- fusion. Its performance relies on hoisting several variables out of the +-- inner loop. That's not possible when writing 'encodeListWith' as a 'foldr'. +-- If we had stream fusion for lists, then we could fuse 'encodeListWith', as +-- 'encodeWithStream' can keep control over the execution. + + +-- | Create a 'Builder' that encodes values with the given 'BoundedPrim'. +-- +-- We rewrite consecutive uses of 'primBounded' such that the bound-checks are +-- fused. For example, +-- +-- > primBounded (word32 c1) `mappend` primBounded (word32 c2) +-- +-- is rewritten such that the resulting 'Builder' checks only once, if ther are +-- at 8 free bytes, instead of checking twice, if there are 4 free bytes. This +-- optimization is not observationally equivalent in a strict sense, as it +-- influences the boundaries of the generated chunks. However, for a user of +-- this library it is observationally equivalent, as chunk boundaries of a +-- 'L.LazyByteString' can only be observed through the internal interface. +-- Moreover, we expect that all primitives write much fewer than 4kb (the +-- default short buffer size). Hence, it is safe to ignore the additional +-- memory spilled due to the more aggressive buffer wrapping introduced by this +-- optimization. +-- +{-# INLINE[1] primBounded #-} +primBounded :: BoundedPrim a -> (a -> Builder) +primBounded w x = + -- It is important to avoid recursive 'BuildStep's where possible, as + -- their closure allocation is expensive. Using 'ensureFree' allows the + -- 'step' to assume that at least 'sizeBound w' free space is available. + ensureFree (I.sizeBound w) `mappend` builder step + where + step k (BufferRange op ope) = do + op' <- runB w x op + let !br' = BufferRange op' ope + k br' + +{-# RULES + +"append/primBounded" forall w1 w2 x1 x2. + append (primBounded w1 x1) (primBounded w2 x2) + = primBounded (pairB w1 w2) (x1, x2) + +"append/primBounded/assoc_r" forall w1 w2 x1 x2 b. + append (primBounded w1 x1) (append (primBounded w2 x2) b) + = append (primBounded (pairB w1 w2) (x1, x2)) b + +"append/primBounded/assoc_l" forall w1 w2 x1 x2 b. + append (append b (primBounded w1 x1)) (primBounded w2 x2) + = append b (primBounded (pairB w1 w2) (x1, x2)) + #-} + +-- TODO: The same rules for 'putBuilder (..) >> putBuilder (..)' + +-- | Create a 'Builder' that encodes a list of values consecutively using a +-- 'BoundedPrim' for each element. This function is more efficient than +-- +-- > mconcat . map (primBounded w) +-- +-- or +-- +-- > foldMap (primBounded w) +-- +-- because it moves several variables out of the inner loop. +{-# INLINE primMapListBounded #-} +primMapListBounded :: BoundedPrim a -> [a] -> Builder +primMapListBounded w xs0 = + builder $ step xs0 + where + step xs1 k (BufferRange op0 ope0) = + go xs1 op0 + where + go [] !op = k (BufferRange op ope0) + go xs@(x':xs') !op + | op `plusPtr` bound <= ope0 = runB w x' op >>= go xs' + | otherwise = + return $ bufferFull bound op (step xs k) + + bound = I.sizeBound w + +-- TODO: Add 'foldMap/encodeWith' its variants +-- TODO: Ensure rewriting 'primBounded w . f = primBounded (w #. f)' + +-- | Create a 'Builder' that encodes a sequence generated from a seed value +-- using a 'BoundedPrim' for each sequence element. +{-# INLINE primUnfoldrBounded #-} +primUnfoldrBounded :: BoundedPrim b -> (a -> Maybe (b, a)) -> a -> Builder +primUnfoldrBounded w f x0 = + builder $ fillWith x0 + where + fillWith x k (BufferRange op0 ope0) = + go (f x) op0 + where + go Nothing !op = k (BufferRange op ope0) + go (Just (y, x')) !op + | op `plusPtr` bound <= ope0 = runB w y op >>= go (f x') + | otherwise = return $ bufferFull bound op $ + \(BufferRange opNew opeNew) -> do + !opNew' <- runB w y opNew + fillWith x' k (BufferRange opNew' opeNew) + bound = I.sizeBound w + +-- | Create a 'Builder' that encodes each 'Word8' of a 'S.StrictByteString' +-- using a 'BoundedPrim'. For example, we can write a 'Builder' that filters +-- a 'S.StrictByteString' as follows. +-- +-- > import qualified Data.ByteString.Builder.Prim as P +-- +-- > filterBS p = P.condB p (P.liftFixedToBounded P.word8) P.emptyB +-- +{-# INLINE primMapByteStringBounded #-} +primMapByteStringBounded :: BoundedPrim Word8 -> S.StrictByteString -> Builder +primMapByteStringBounded w = + \bs -> builder $ step bs + where + bound = I.sizeBound w + step (S.BS ifp isize) !k = + goBS (unsafeForeignPtrToPtr ifp) + where + !ipe = unsafeForeignPtrToPtr ifp `plusPtr` isize + goBS !ip0 br@(BufferRange op0 ope) + | ip0 >= ipe = do + touchForeignPtr ifp -- input buffer consumed + k br + + | op0 `plusPtr` bound <= ope = + goPartial (ip0 `plusPtr` min outRemaining inpRemaining) + + | otherwise = return $ bufferFull bound op0 (goBS ip0) + where + outRemaining = (ope `minusPtr` op0) `div` bound + inpRemaining = ipe `minusPtr` ip0 + + goPartial !ipeTmp = go ip0 op0 + where + go !ip !op + | ip < ipeTmp = do + x <- peek ip + op' <- runB w x op + go (ip `plusPtr` 1) op' + | otherwise = + goBS ip (BufferRange op ope) + +-- | Chunk-wise application of 'primMapByteStringBounded'. +{-# INLINE primMapLazyByteStringBounded #-} +primMapLazyByteStringBounded :: BoundedPrim Word8 -> L.LazyByteString -> Builder +primMapLazyByteStringBounded w = + L.foldrChunks (\x b -> primMapByteStringBounded w x `mappend` b) mempty + + +------------------------------------------------------------------------------ +-- Raw CString encoding +------------------------------------------------------------------------------ + +-- | A null-terminated ASCII encoded 'Foreign.C.String.CString'. +-- Null characters are not representable. +-- +-- @since 0.11.0.0 +cstring :: Addr# -> Builder +cstring = + \addr0 -> builder $ step addr0 + where + step :: Addr# -> BuildStep r -> BuildStep r + step !addr !k br@(BufferRange op0@(Ptr op0#) ope) + | W8# ch == 0 = k br + | op0 == ope = + return $ bufferFull 1 op0 (step addr k) + | otherwise = do + IO $ \s -> case writeWord8OffAddr# op0# 0# ch s of + s' -> (# s', () #) + let br' = BufferRange (op0 `plusPtr` 1) ope + step (addr `plusAddr#` 1#) k br' + where + !ch = indexWord8OffAddr# addr 0# + +-- | A null-terminated UTF-8 encoded 'Foreign.C.String.CString'. +-- Null characters can be encoded as @0xc0 0x80@. +-- +-- @since 0.11.0.0 +cstringUtf8 :: Addr# -> Builder +cstringUtf8 = + \addr0 -> builder $ step addr0 + where + step :: Addr# -> BuildStep r -> BuildStep r + step !addr !k br@(BufferRange op0@(Ptr op0#) ope) + | W8# ch == 0 = k br + | op0 == ope = + return $ bufferFull 1 op0 (step addr k) + -- NULL is encoded as 0xc0 0x80 + | W8# ch == 0xc0 + , W8# (indexWord8OffAddr# addr 1#) == 0x80 = do + let !(W8# nullByte#) = 0 + IO $ \s -> case writeWord8OffAddr# op0# 0# nullByte# s of + s' -> (# s', () #) + let br' = BufferRange (op0 `plusPtr` 1) ope + step (addr `plusAddr#` 2#) k br' + | otherwise = do + IO $ \s -> case writeWord8OffAddr# op0# 0# ch s of + s' -> (# s', () #) + let br' = BufferRange (op0 `plusPtr` 1) ope + step (addr `plusAddr#` 1#) k br' + where + !ch = indexWord8OffAddr# addr 0# + +------------------------------------------------------------------------------ +-- Char8 encoding +------------------------------------------------------------------------------ + +-- | Char8 encode a 'Char'. +{-# INLINE char8 #-} +char8 :: FixedPrim Char +char8 = (fromIntegral . ord) >$< word8 + + +------------------------------------------------------------------------------ +-- UTF-8 encoding +------------------------------------------------------------------------------ + +-- | UTF-8 encode a 'Char'. +{-# INLINE charUtf8 #-} +charUtf8 :: BoundedPrim Char +charUtf8 = boundedPrim 4 (encodeCharUtf8 f1 f2 f3 f4) + where + pokeN n io op = io op >> return (op `plusPtr` n) + + f1 x1 = pokeN 1 $ \op -> pokeByteOff op 0 x1 + + f2 x1 x2 = pokeN 2 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + + f3 x1 x2 x3 = pokeN 3 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + pokeByteOff op 2 x3 + + f4 x1 x2 x3 x4 = pokeN 4 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + pokeByteOff op 2 x3 + pokeByteOff op 3 x4 + +-- | Encode a Unicode character to another datatype, using UTF-8. This function +-- acts as an abstract way of encoding characters, as it is unaware of what +-- needs to happen with the resulting bytes: you have to specify functions to +-- deal with those. +-- +{-# INLINE encodeCharUtf8 #-} +encodeCharUtf8 :: (Word8 -> a) -- ^ 1-byte UTF-8 + -> (Word8 -> Word8 -> a) -- ^ 2-byte UTF-8 + -> (Word8 -> Word8 -> Word8 -> a) -- ^ 3-byte UTF-8 + -> (Word8 -> Word8 -> Word8 -> Word8 -> a) -- ^ 4-byte UTF-8 + -> Char -- ^ Input 'Char' + -> a -- ^ Result +encodeCharUtf8 f1 f2 f3 f4 c = case ord c of + x | x <= 0x7F -> f1 $ fromIntegral x + | x <= 0x07FF -> + let x1 = fromIntegral $ (x `shiftR` 6) + 0xC0 + x2 = fromIntegral $ (x .&. 0x3F) + 0x80 + in f2 x1 x2 + | x <= 0xFFFF -> + let x1 = fromIntegral $ (x `shiftR` 12) + 0xE0 + x2 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 + x3 = fromIntegral $ (x .&. 0x3F) + 0x80 + in f3 x1 x2 x3 + | otherwise -> + let x1 = fromIntegral $ (x `shiftR` 18) + 0xF0 + x2 = fromIntegral $ ((x `shiftR` 12) .&. 0x3F) + 0x80 + x3 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 + x4 = fromIntegral $ (x .&. 0x3F) + 0x80 + in f4 x1 x2 x3 x4 diff --git a/Data/ByteString/Builder/Prim/ASCII.hs b/Data/ByteString/Builder/Prim/ASCII.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Prim/ASCII.hs @@ -0,0 +1,268 @@ +-- | Copyright : (c) 2010 Jasper Van der Jeugt +-- (c) 2010 - 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +-- Encodings using ASCII encoded Unicode characters. +-- +module Data.ByteString.Builder.Prim.ASCII + ( + + -- *** ASCII + char7 + + -- **** Decimal numbers + -- | Decimal encoding of numbers using ASCII encoded characters. + , int8Dec + , int16Dec + , int32Dec + , int64Dec + , intDec + + , word8Dec + , word16Dec + , word32Dec + , word64Dec + , wordDec + + {- + -- These are the functions currently provided by Bryan O'Sullivans + -- double-conversion library. + -- + -- , float + -- , floatWith + -- , double + -- , doubleWith + -} + + -- **** Hexadecimal numbers + + -- | Encoding positive integers as hexadecimal numbers using lower-case + -- ASCII characters. The shortest possible representation is used. For + -- example, + -- + -- > toLazyByteString (primBounded word16Hex 0x0a10) = "a10" + -- + -- Note that there is no support for using upper-case characters. Please + -- contact the maintainer if your application cannot work without + -- hexadecimal encodings that use upper-case characters. + -- + , word8Hex + , word16Hex + , word32Hex + , word64Hex + , wordHex + + -- **** Fixed-width hexadecimal numbers + -- + -- | Encoding the bytes of fixed-width types as hexadecimal + -- numbers using lower-case ASCII characters. For example, + -- + -- > toLazyByteString (primFixed word16HexFixed 0x0a10) = "0a10" + -- + , int8HexFixed + , int16HexFixed + , int32HexFixed + , int64HexFixed + , word8HexFixed + , word16HexFixed + , word32HexFixed + , word64HexFixed + , floatHexFixed + , doubleHexFixed + + ) where + +import Data.ByteString.Internal.Type +import Data.ByteString.Builder.Prim.Binary +import Data.ByteString.Builder.Prim.Internal +import Data.ByteString.Builder.Prim.Internal.Floating +import Data.ByteString.Builder.Prim.Internal.Base16 +import Data.ByteString.Utils.UnalignedAccess + +import Data.Char (ord) + +import Foreign + +-- | Encode the least 7-bits of a 'Char' using the ASCII encoding. +{-# INLINE char7 #-} +char7 :: FixedPrim Char +char7 = (\c -> fromIntegral $ ord c .&. 0x7f) >$< word8 + + +------------------------------------------------------------------------------ +-- Decimal Encoding +------------------------------------------------------------------------------ + +-- Signed integers +------------------ + +{-# INLINE encodeIntDecimal #-} +encodeIntDecimal :: Integral a => Int -> BoundedPrim a +encodeIntDecimal bound = boundedPrim bound $ c_int_dec . fromIntegral + +-- | Decimal encoding of an 'Int8'. +{-# INLINE int8Dec #-} +int8Dec :: BoundedPrim Int8 +int8Dec = encodeIntDecimal 4 + +-- | Decimal encoding of an 'Int16'. +{-# INLINE int16Dec #-} +int16Dec :: BoundedPrim Int16 +int16Dec = encodeIntDecimal 6 + + +-- | Decimal encoding of an 'Int32'. +{-# INLINE int32Dec #-} +int32Dec :: BoundedPrim Int32 +int32Dec = encodeIntDecimal 11 + +-- | Decimal encoding of an 'Int64'. +{-# INLINE int64Dec #-} +int64Dec :: BoundedPrim Int64 +int64Dec = boundedPrim 20 $ c_long_long_int_dec . fromIntegral + +-- | Decimal encoding of an 'Int'. +{-# INLINE intDec #-} +intDec :: BoundedPrim Int +intDec = caseWordSize_32_64 + (fromIntegral >$< int32Dec) + (fromIntegral >$< int64Dec) + + +-- Unsigned integers +-------------------- + +{-# INLINE encodeWordDecimal #-} +encodeWordDecimal :: Integral a => Int -> BoundedPrim a +encodeWordDecimal bound = boundedPrim bound $ c_uint_dec . fromIntegral + +-- | Decimal encoding of a 'Word8'. +{-# INLINE word8Dec #-} +word8Dec :: BoundedPrim Word8 +word8Dec = encodeWordDecimal 3 + +-- | Decimal encoding of a 'Word16'. +{-# INLINE word16Dec #-} +word16Dec :: BoundedPrim Word16 +word16Dec = encodeWordDecimal 5 + +-- | Decimal encoding of a 'Word32'. +{-# INLINE word32Dec #-} +word32Dec :: BoundedPrim Word32 +word32Dec = encodeWordDecimal 10 + +-- | Decimal encoding of a 'Word64'. +{-# INLINE word64Dec #-} +word64Dec :: BoundedPrim Word64 +word64Dec = boundedPrim 20 $ c_long_long_uint_dec . fromIntegral + +-- | Decimal encoding of a 'Word'. +{-# INLINE wordDec #-} +wordDec :: BoundedPrim Word +wordDec = caseWordSize_32_64 + (fromIntegral >$< word32Dec) + (fromIntegral >$< word64Dec) + +------------------------------------------------------------------------------ +-- Hexadecimal Encoding +------------------------------------------------------------------------------ + +-- without lead +--------------- + +{-# INLINE encodeWordHex #-} +encodeWordHex :: forall a. (Storable a, Integral a) => BoundedPrim a +encodeWordHex = + boundedPrim (2 * sizeOf (undefined :: a)) $ c_uint_hex . fromIntegral + +-- | Hexadecimal encoding of a 'Word8'. +{-# INLINE word8Hex #-} +word8Hex :: BoundedPrim Word8 +word8Hex = encodeWordHex + +-- | Hexadecimal encoding of a 'Word16'. +{-# INLINE word16Hex #-} +word16Hex :: BoundedPrim Word16 +word16Hex = encodeWordHex + +-- | Hexadecimal encoding of a 'Word32'. +{-# INLINE word32Hex #-} +word32Hex :: BoundedPrim Word32 +word32Hex = encodeWordHex + +-- | Hexadecimal encoding of a 'Word64'. +{-# INLINE word64Hex #-} +word64Hex :: BoundedPrim Word64 +word64Hex = boundedPrim 16 $ c_long_long_uint_hex . fromIntegral + +-- | Hexadecimal encoding of a 'Word'. +{-# INLINE wordHex #-} +wordHex :: BoundedPrim Word +wordHex = caseWordSize_32_64 + (fromIntegral >$< word32Hex) + (fromIntegral >$< word64Hex) + + +-- fixed width; leading zeroes +------------------------------ + +-- | Encode a 'Word8' using 2 nibbles (hexadecimal digits). +{-# INLINE word8HexFixed #-} +word8HexFixed :: FixedPrim Word8 +word8HexFixed = fixedPrim 2 $ \x op -> do + enc <- encode8_as_16h lowerTable x + unalignedWriteU16 enc op + +-- | Encode a 'Word16' using 4 nibbles. +{-# INLINE word16HexFixed #-} +word16HexFixed :: FixedPrim Word16 +word16HexFixed = + (\x -> (fromIntegral $ x `shiftR` 8, fromIntegral x)) + >$< pairF word8HexFixed word8HexFixed + +-- | Encode a 'Word32' using 8 nibbles. +{-# INLINE word32HexFixed #-} +word32HexFixed :: FixedPrim Word32 +word32HexFixed = + (\x -> (fromIntegral $ x `shiftR` 16, fromIntegral x)) + >$< pairF word16HexFixed word16HexFixed + +-- | Encode a 'Word64' using 16 nibbles. +{-# INLINE word64HexFixed #-} +word64HexFixed :: FixedPrim Word64 +word64HexFixed = + (\x -> (fromIntegral $ x `shiftR` 32, fromIntegral x)) + >$< pairF word32HexFixed word32HexFixed + +-- | Encode a 'Int8' using 2 nibbles (hexadecimal digits). +{-# INLINE int8HexFixed #-} +int8HexFixed :: FixedPrim Int8 +int8HexFixed = fromIntegral >$< word8HexFixed + +-- | Encode a 'Int16' using 4 nibbles. +{-# INLINE int16HexFixed #-} +int16HexFixed :: FixedPrim Int16 +int16HexFixed = fromIntegral >$< word16HexFixed + +-- | Encode a 'Int32' using 8 nibbles. +{-# INLINE int32HexFixed #-} +int32HexFixed :: FixedPrim Int32 +int32HexFixed = fromIntegral >$< word32HexFixed + +-- | Encode a 'Int64' using 16 nibbles. +{-# INLINE int64HexFixed #-} +int64HexFixed :: FixedPrim Int64 +int64HexFixed = fromIntegral >$< word64HexFixed + +-- | Encode an IEEE 'Float' using 8 nibbles. +{-# INLINE floatHexFixed #-} +floatHexFixed :: FixedPrim Float +floatHexFixed = encodeFloatViaWord32F word32HexFixed + +-- | Encode an IEEE 'Double' using 16 nibbles. +{-# INLINE doubleHexFixed #-} +doubleHexFixed :: FixedPrim Double +doubleHexFixed = encodeDoubleViaWord64F word64HexFixed diff --git a/Data/ByteString/Builder/Prim/Binary.hs b/Data/ByteString/Builder/Prim/Binary.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Prim/Binary.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE Trustworthy #-} + +-- | Copyright : (c) 2010-2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +module Data.ByteString.Builder.Prim.Binary ( + + -- ** Binary encodings + int8 + , word8 + + -- *** Big-endian + , int16BE + , int32BE + , int64BE + + , word16BE + , word32BE + , word64BE + + , floatBE + , doubleBE + + -- *** Little-endian + , int16LE + , int32LE + , int64LE + + , word16LE + , word32LE + , word64LE + + , floatLE + , doubleLE + + -- *** Non-portable, host-dependent + , intHost + , int16Host + , int32Host + , int64Host + + , wordHost + , word16Host + , word32Host + , word64Host + + , floatHost + , doubleHost + + ) where + +import Data.ByteString.Builder.Prim.Internal +import Data.ByteString.Builder.Prim.Internal.Floating +import Data.ByteString.Utils.ByteOrder +import Data.ByteString.Utils.UnalignedAccess + +import Foreign + +------------------------------------------------------------------------------ +-- Binary encoding +------------------------------------------------------------------------------ + +-- Word encodings +----------------- + +-- | Encoding single unsigned bytes as-is. +-- +{-# INLINE word8 #-} +word8 :: FixedPrim Word8 +word8 = fixedPrim 1 (flip poke) -- Word8 is always aligned + +-- +-- We rely on the fromIntegral to do the right masking for us. +-- The inlining here is critical, and can be worth 4x performance +-- + +-- | Encoding 'Word16's in big endian format. +{-# INLINE word16BE #-} +word16BE :: FixedPrim Word16 +word16BE = whenLittleEndian byteSwap16 >$< word16Host + +-- | Encoding 'Word16's in little endian format. +{-# INLINE word16LE #-} +word16LE :: FixedPrim Word16 +word16LE = whenBigEndian byteSwap16 >$< word16Host + +-- | Encoding 'Word32's in big endian format. +{-# INLINE word32BE #-} +word32BE :: FixedPrim Word32 +word32BE = whenLittleEndian byteSwap32 >$< word32Host + +-- | Encoding 'Word32's in little endian format. +{-# INLINE word32LE #-} +word32LE :: FixedPrim Word32 +word32LE = whenBigEndian byteSwap32 >$< word32Host + +-- on a little endian machine: +-- word32LE w32 = fixedPrim 4 (\w p -> poke (castPtr p) w32) + +-- | Encoding 'Word64's in big endian format. +{-# INLINE word64BE #-} +word64BE :: FixedPrim Word64 +word64BE = whenLittleEndian byteSwap64 >$< word64Host + +-- | Encoding 'Word64's in little endian format. +{-# INLINE word64LE #-} +word64LE :: FixedPrim Word64 +word64LE = whenBigEndian byteSwap64 >$< word64Host + + +-- | Encode a single native machine 'Word'. The 'Word's is encoded in host order, +-- host endian form, for the machine you are on. On a 64 bit machine the 'Word' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way +-- are not portable to different endian or word sized machines, without +-- conversion. +-- +{-# INLINE wordHost #-} +wordHost :: FixedPrim Word +wordHost = case finiteBitSize (0 :: Word) of + 32 -> fromIntegral @Word @Word32 >$< word32Host + 64 -> fromIntegral @Word @Word64 >$< word64Host + _ -> error "Data.ByteString.Builder.Prim.Binary.wordHost: unexpected word size" + +-- | Encoding 'Word16's in native host order and host endianness. +{-# INLINE word16Host #-} +word16Host :: FixedPrim Word16 +word16Host = fixedPrim 2 unalignedWriteU16 + +-- | Encoding 'Word32's in native host order and host endianness. +{-# INLINE word32Host #-} +word32Host :: FixedPrim Word32 +word32Host = fixedPrim 4 unalignedWriteU32 + +-- | Encoding 'Word64's in native host order and host endianness. +{-# INLINE word64Host #-} +word64Host :: FixedPrim Word64 +word64Host = fixedPrim 8 unalignedWriteU64 + +------------------------------------------------------------------------------ +-- Int encodings +------------------------------------------------------------------------------ +-- +-- We rely on 'fromIntegral' to do a loss-less conversion to the corresponding +-- 'Word' type +-- +------------------------------------------------------------------------------ + +-- | Encoding single signed bytes as-is. +-- +{-# INLINE int8 #-} +int8 :: FixedPrim Int8 +int8 = fromIntegral >$< word8 + +-- | Encoding 'Int16's in big endian format. +{-# INLINE int16BE #-} +int16BE :: FixedPrim Int16 +int16BE = fromIntegral >$< word16BE + +-- | Encoding 'Int16's in little endian format. +{-# INLINE int16LE #-} +int16LE :: FixedPrim Int16 +int16LE = fromIntegral >$< word16LE + +-- | Encoding 'Int32's in big endian format. +{-# INLINE int32BE #-} +int32BE :: FixedPrim Int32 +int32BE = fromIntegral >$< word32BE + +-- | Encoding 'Int32's in little endian format. +{-# INLINE int32LE #-} +int32LE :: FixedPrim Int32 +int32LE = fromIntegral >$< word32LE + +-- | Encoding 'Int64's in big endian format. +{-# INLINE int64BE #-} +int64BE :: FixedPrim Int64 +int64BE = fromIntegral >$< word64BE + +-- | Encoding 'Int64's in little endian format. +{-# INLINE int64LE #-} +int64LE :: FixedPrim Int64 +int64LE = fromIntegral >$< word64LE + + +-- | Encode a single native machine 'Int'. The 'Int's is encoded in host order, +-- host endian form, for the machine you are on. On a 64 bit machine the 'Int' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way +-- are not portable to different endian or integer sized machines, without +-- conversion. +-- +{-# INLINE intHost #-} +intHost :: FixedPrim Int +intHost = fromIntegral @Int @Word >$< wordHost + +-- | Encoding 'Int16's in native host order and host endianness. +{-# INLINE int16Host #-} +int16Host :: FixedPrim Int16 +int16Host = fromIntegral @Int16 @Word16 >$< word16Host + +-- | Encoding 'Int32's in native host order and host endianness. +{-# INLINE int32Host #-} +int32Host :: FixedPrim Int32 +int32Host = fromIntegral @Int32 @Word32 >$< word32Host + +-- | Encoding 'Int64's in native host order and host endianness. +{-# INLINE int64Host #-} +int64Host :: FixedPrim Int64 +int64Host = fromIntegral @Int64 @Word64 >$< word64Host + +-- IEEE Floating Point Numbers +------------------------------ + +-- | Encode a 'Float' in big endian format. +{-# INLINE floatBE #-} +floatBE :: FixedPrim Float +floatBE = encodeFloatViaWord32F word32BE + +-- | Encode a 'Float' in little endian format. +{-# INLINE floatLE #-} +floatLE :: FixedPrim Float +floatLE = encodeFloatViaWord32F word32LE + +-- | Encode a 'Double' in big endian format. +{-# INLINE doubleBE #-} +doubleBE :: FixedPrim Double +doubleBE = encodeDoubleViaWord64F word64BE + +-- | Encode a 'Double' in little endian format. +{-# INLINE doubleLE #-} +doubleLE :: FixedPrim Double +doubleLE = encodeDoubleViaWord64F word64LE + + +-- | Encode a 'Float' in native host order and host endianness. Values written +-- this way are not portable to different endian machines, without conversion. +-- +{-# INLINE floatHost #-} +floatHost :: FixedPrim Float +floatHost = fixedPrim (sizeOf @Float 0) unalignedWriteFloat + +-- | Encode a 'Double' in native host order and host endianness. +{-# INLINE doubleHost #-} +doubleHost :: FixedPrim Double +doubleHost = fixedPrim (sizeOf @Double 0) unalignedWriteDouble diff --git a/Data/ByteString/Builder/Prim/Internal.hs b/Data/ByteString/Builder/Prim/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Prim/Internal.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Unsafe #-} + +{-# OPTIONS_HADDOCK not-home #-} + +-- | +-- Copyright : 2010-2011 Simon Meier, 2010 Jasper van der Jeugt +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : unstable, private +-- Portability : GHC +-- +-- *Warning:* this module is internal. If you find that you need it please +-- contact the maintainers and explain what you are trying to do and discuss +-- what you would need in the public API. It is important that you do this as +-- the module may not be exposed at all in future releases. +-- +-- The maintainers are glad to accept patches for further +-- standard encodings of standard Haskell values. +-- +-- If you need to write your own builder primitives, then be aware that you are +-- writing code with /all safety belts off/; i.e., +-- *this is the code that might make your application vulnerable to buffer-overflow attacks!* +-- The "Data.ByteString.Builder.Prim.Tests" module provides you with +-- utilities for testing your encodings thoroughly. +-- +module Data.ByteString.Builder.Prim.Internal ( + -- * Fixed-size builder primitives + Size + , FixedPrim + , fixedPrim + , size + , runF + + , emptyF + , contramapF + , pairF + -- , liftIOF + + , storableToF + + -- * Bounded-size builder primitives + , BoundedPrim + , boundedPrim + , sizeBound + , runB + + , emptyB + , contramapB + , pairB + , eitherB + , condB + + -- , liftIOB + + , toB + , liftFixedToBounded + + -- , withSizeFB + -- , withSizeBB + + -- * Shared operators + , (>$<) + , (>*<) + + -- * Helpers + , caseWordSize_32_64 + + -- * Deprecated + , boudedPrim + ) where + +import Foreign +import Prelude hiding (maxBound) + +#include "MachDeps.h" +#include "bytestring-cpp-macros.h" + +------------------------------------------------------------------------------ +-- Supporting infrastructure +------------------------------------------------------------------------------ + +-- | Contravariant functors as in the @contravariant@ package. +class Contravariant f where + contramap :: (b -> a) -> f a -> f b + +infixl 4 >$< + +-- | A fmap-like operator for builder primitives, both bounded and fixed size. +-- +-- Builder primitives are contravariant so it's like the normal fmap, but +-- backwards (look at the type). (If it helps to remember, the operator symbol +-- is like (<$>) but backwards.) +-- +-- We can use it for example to prepend and/or append fixed values to an +-- primitive. +-- +-- > import Data.ByteString.Builder.Prim as P +-- >showEncoding ((\x -> ('\'', (x, '\''))) >$< fixed3) 'x' = "'x'" +-- > where +-- > fixed3 = P.char7 >*< P.char7 >*< P.char7 +-- +-- Note that the rather verbose syntax for composition stems from the +-- requirement to be able to compute the size / size bound at compile time. +-- +(>$<) :: Contravariant f => (b -> a) -> f a -> f b +(>$<) = contramap + + +instance Contravariant FixedPrim where + contramap = contramapF + +instance Contravariant BoundedPrim where + contramap = contramapB + + +-- | Type-constructors supporting lifting of type-products. +class Monoidal f where + pair :: f a -> f b -> f (a, b) + +instance Monoidal FixedPrim where + pair = pairF + +instance Monoidal BoundedPrim where + pair = pairB + +infixr 5 >*< + +-- | A pairing/concatenation operator for builder primitives, both bounded and +-- fixed size. +-- +-- For example, +-- +-- > toLazyByteString (primFixed (char7 >*< char7) ('x','y')) = "xy" +-- +-- We can combine multiple primitives using '>*<' multiple times. +-- +-- > toLazyByteString (primFixed (char7 >*< char7 >*< char7) ('x',('y','z'))) = "xyz" +-- +(>*<) :: Monoidal f => f a -> f b -> f (a, b) +(>*<) = pair + + +-- | The type used for sizes and sizeBounds of sizes. +type Size = Int + + +------------------------------------------------------------------------------ +-- Fixed-size builder primitives +------------------------------------------------------------------------------ + +-- | A builder primitive that always results in a sequence of bytes of a +-- pre-determined, fixed size. +data FixedPrim a = FP {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO ()) + +fixedPrim :: Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a +fixedPrim = FP + +-- | The size of the sequences of bytes generated by this 'FixedPrim'. +{-# INLINE CONLIKE size #-} +size :: FixedPrim a -> Int +size (FP l _) = l + +{-# INLINE CONLIKE runF #-} +runF :: FixedPrim a -> a -> Ptr Word8 -> IO () +runF (FP _ io) = io + +-- | The 'FixedPrim' that always results in the zero-length sequence. +{-# INLINE CONLIKE emptyF #-} +emptyF :: FixedPrim a +emptyF = FP 0 (\_ _ -> return ()) + +-- | Encode a pair by encoding its first component and then its second component. +{-# INLINE CONLIKE pairF #-} +pairF :: FixedPrim a -> FixedPrim b -> FixedPrim (a, b) +pairF (FP l1 io1) (FP l2 io2) = + FP (l1 + l2) (\(x1,x2) op -> io1 x1 op >> io2 x2 (op `plusPtr` l1)) + +-- | Change a primitives such that it first applies a function to the value +-- to be encoded. +-- +-- Note that primitives are 'Contravariant' +-- . Hence, the following +-- laws hold. +-- +-- >contramapF id = id +-- >contramapF f . contramapF g = contramapF (g . f) +{-# INLINE CONLIKE contramapF #-} +contramapF :: (b -> a) -> FixedPrim a -> FixedPrim b +contramapF f (FP l io) = FP l (io . f) + +-- | Convert a 'FixedPrim' to a 'BoundedPrim'. +{-# INLINE CONLIKE toB #-} +toB :: FixedPrim a -> BoundedPrim a +toB (FP l io) = BP l (\x op -> io x op >> (return $! op `plusPtr` l)) + +-- | Lift a 'FixedPrim' to a 'BoundedPrim'. +{-# INLINE CONLIKE liftFixedToBounded #-} +liftFixedToBounded :: FixedPrim a -> BoundedPrim a +liftFixedToBounded = toB + +{-# INLINE CONLIKE storableToF #-} +{-# DEPRECATED storableToF + "Deprecated since @bytestring-0.12.1.0@.\n\nThis function is dangerous in the presence of internal padding\nand makes naive assumptions about alignment.\n\n * For a primitive Haskell type like 'Int64', use the\n corresponding primitive like 'Data.ByteString.Builder.Prim.int64Host'.\n * For other types, it is recommended to manually write a small\n function that performs the necessary unaligned write\n and zeroes or removes any internal padding bits." + #-} +storableToF :: forall a. Storable a => FixedPrim a +#if HS_UNALIGNED_POKES_OK +storableToF = FP (sizeOf (undefined :: a)) (\x op -> poke (castPtr op) x) +#else +storableToF = FP (sizeOf (undefined :: a)) $ \x op -> + if ptrToWordPtr op `mod` fromIntegral (alignment (undefined :: a)) == 0 then poke (castPtr op) x + else with x $ \tp -> copyBytes op (castPtr tp) (sizeOf (undefined :: a)) +#endif + +{- +{-# INLINE CONLIKE liftIOF #-} +liftIOF :: FixedPrim a -> FixedPrim (IO a) +liftIOF (FP l io) = FP l (\xWrapped op -> do x <- xWrapped; io x op) +-} + +------------------------------------------------------------------------------ +-- Bounded-size builder primitives +------------------------------------------------------------------------------ + +-- | A builder primitive that always results in sequence of bytes that is no longer +-- than a pre-determined bound. +data BoundedPrim a = BP {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO (Ptr Word8)) + +-- | The bound on the size of sequences of bytes generated by this 'BoundedPrim'. +{-# INLINE CONLIKE sizeBound #-} +sizeBound :: BoundedPrim a -> Int +sizeBound (BP b _) = b + +-- | @since 0.10.12.0 +boundedPrim :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a +boundedPrim = BP + +{-# DEPRECATED boudedPrim "Use 'boundedPrim' instead" #-} +boudedPrim :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a +boudedPrim = BP + +{-# INLINE CONLIKE runB #-} +runB :: BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8) +runB (BP _ io) = io + +-- | Change a 'BoundedPrim' such that it first applies a function to the +-- value to be encoded. +-- +-- Note that 'BoundedPrim's are 'Contravariant' +-- . Hence, the following +-- laws hold. +-- +-- >contramapB id = id +-- >contramapB f . contramapB g = contramapB (g . f) +{-# INLINE CONLIKE contramapB #-} +contramapB :: (b -> a) -> BoundedPrim a -> BoundedPrim b +contramapB f (BP b io) = BP b (io . f) + +-- | The 'BoundedPrim' that always results in the zero-length sequence. +{-# INLINE CONLIKE emptyB #-} +emptyB :: BoundedPrim a +emptyB = BP 0 (\_ op -> return op) + +-- | Encode a pair by encoding its first component and then its second component. +{-# INLINE CONLIKE pairB #-} +pairB :: BoundedPrim a -> BoundedPrim b -> BoundedPrim (a, b) +pairB (BP b1 io1) (BP b2 io2) = + BP (b1 + b2) (\(x1,x2) op -> io1 x1 op >>= io2 x2) + +-- | Encode an 'Either' value using the first 'BoundedPrim' for 'Left' +-- values and the second 'BoundedPrim' for 'Right' values. +-- +-- Note that the functions 'eitherB', 'pairB', and 'contramapB' (written below +-- using '>$<') suffice to construct 'BoundedPrim's for all non-recursive +-- algebraic datatypes. For example, +-- +-- @ +--maybeB :: BoundedPrim () -> BoundedPrim a -> BoundedPrim (Maybe a) +--maybeB nothing just = 'maybe' (Left ()) Right '>$<' eitherB nothing just +-- @ +{-# INLINE CONLIKE eitherB #-} +eitherB :: BoundedPrim a -> BoundedPrim b -> BoundedPrim (Either a b) +eitherB (BP b1 io1) (BP b2 io2) = + BP (max b1 b2) + (\x op -> case x of Left x1 -> io1 x1 op; Right x2 -> io2 x2 op) + +-- | Conditionally select a 'BoundedPrim'. +-- For example, we can implement the ASCII primitive that drops characters with +-- Unicode codepoints above 127 as follows. +-- +-- @ +--charASCIIDrop = 'condB' (< \'\\128\') ('liftFixedToBounded' 'Data.ByteString.Builder.Prim.char7') 'emptyB' +-- @ +{-# INLINE CONLIKE condB #-} +condB :: (a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a +condB p be1 be2 = + contramapB (\x -> if p x then Left x else Right x) (eitherB be1 be2) + +-- | Select an implementation depending on bitness. +-- Throw a compile time error if bitness is neither 32 nor 64. +{-# INLINE caseWordSize_32_64 #-} +caseWordSize_32_64 + :: a -- Value for 32-bit architecture + -> a -- Value for 64-bit architecture + -> a +#if WORD_SIZE_IN_BITS == 32 +caseWordSize_32_64 = const +#endif +#if WORD_SIZE_IN_BITS == 64 +caseWordSize_32_64 = const id +#endif diff --git a/Data/ByteString/Builder/Prim/Internal/Base16.hs b/Data/ByteString/Builder/Prim/Internal/Base16.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Prim/Internal/Base16.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : GHC +-- +-- Hexadecimal encoding of nibbles (4-bit) and octets (8-bit) as ASCII +-- characters. +-- +-- The current implementation is based on a table based encoding inspired by +-- the code in the 'base64-bytestring' library by Bryan O'Sullivan. In our +-- benchmarks on a 32-bit machine it turned out to be the fastest +-- implementation option. +-- +module Data.ByteString.Builder.Prim.Internal.Base16 ( + EncodingTable + , lowerTable + , encode8_as_16h + ) where + +import Foreign +import GHC.Exts (Addr#, Ptr(..)) +#if PURE_HASKELL +import qualified Data.ByteString.Internal.Pure as Pure +#else +import Foreign.C.Types +#endif + +-- Creating the encoding table +------------------------------ + +-- | An encoding table for Base16 encoding. +data EncodingTable = EncodingTable Addr# + +-- | The encoding table for hexadecimal values with lower-case characters; +-- e.g., deadbeef. +lowerTable :: EncodingTable +lowerTable = +#if PURE_HASKELL + case Pure.lower_hex_table of + Ptr p# -> EncodingTable p# +#else + case c_lower_hex_table of + Ptr p# -> EncodingTable p# + +foreign import ccall "&hs_bytestring_lower_hex_table" + c_lower_hex_table :: Ptr CChar +#endif + +-- | Encode an octet as 16bit word comprising both encoded nibbles ordered +-- according to the host endianness. Writing these 16bit to memory will write +-- the nibbles in the correct order (i.e. big-endian). +{-# INLINE encode8_as_16h #-} +encode8_as_16h :: EncodingTable -> Word8 -> IO Word16 +encode8_as_16h (EncodingTable table) = + peekElemOff (Ptr table) . fromIntegral diff --git a/Data/ByteString/Builder/Prim/Internal/Floating.hs b/Data/ByteString/Builder/Prim/Internal/Floating.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Prim/Internal/Floating.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE CPP #-} + +#include "MachDeps.h" +#include "bytestring-cpp-macros.h" + +-- | +-- Copyright : (c) 2010 Simon Meier +-- +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : GHC +-- +-- Conversion of 'Float's and 'Double's to 'Word32's and 'Word64's. +-- +module Data.ByteString.Builder.Prim.Internal.Floating + ( castFloatToWord32 + , castDoubleToWord64 + , encodeFloatViaWord32F + , encodeDoubleViaWord64F + ) where + +import Data.ByteString.Builder.Prim.Internal +import Data.Word + +#if HS_CAST_FLOAT_WORD_OPS_AVAILABLE +import GHC.Float (castFloatToWord32, castDoubleToWord64) +#else +import Foreign.Marshal.Utils +import Foreign.Storable +import Foreign.Ptr + +import Data.ByteString.Internal.Type (unsafeDupablePerformIO) +{- +We work around ticket http://ghc.haskell.org/trac/ghc/ticket/4092 by +storing the Float/Double in a temp buffer and peeking it out again from there. +-} + +-- | Interpret a 'Float' as a 'Word32' as if through a bit-for-bit copy. +-- (fallback if not available through GHC.Float) +-- +-- e.g +-- +-- > showHex (castFloatToWord32 1.0) [] = "3f800000" +{-# NOINLINE castFloatToWord32 #-} +castFloatToWord32 :: Float -> Word32 +#if (SIZEOF_HSFLOAT != SIZEOF_WORD32) || (ALIGNMENT_HSFLOAT < ALIGNMENT_WORD32) + #error "don't know how to cast Float to Word32" +#endif +castFloatToWord32 x = unsafeDupablePerformIO (with x (peek . castPtr)) + +-- | Interpret a 'Double' as a 'Word64' as if through a bit-for-bit copy. +-- (fallback if not available through GHC.Float) +-- +-- e.g +-- +-- > showHex (castDoubleToWord64 1.0) [] = "3ff0000000000000" +{-# NOINLINE castDoubleToWord64 #-} +castDoubleToWord64 :: Double -> Word64 +#if (SIZEOF_HSDOUBLE != SIZEOF_WORD64) || (ALIGNMENT_HSDOUBLE < ALIGNMENT_WORD64) + #error "don't know how to cast Double to Word64" +#endif +castDoubleToWord64 x = unsafeDupablePerformIO (with x (peek . castPtr)) +#endif + + +-- | Encode a 'Float' using a 'Word32' encoding. +{-# INLINE encodeFloatViaWord32F #-} +encodeFloatViaWord32F :: FixedPrim Word32 -> FixedPrim Float +#if HS_CAST_FLOAT_WORD_OPS_AVAILABLE +encodeFloatViaWord32F = (castFloatToWord32 >$<) +#else +encodeFloatViaWord32F w32fe = fixedPrim (size w32fe) $ \x op -> do + x' <- with x (peek . castPtr) + runF w32fe x' op +#endif + +-- | Encode a 'Double' using a 'Word64' encoding. +{-# INLINE encodeDoubleViaWord64F #-} +encodeDoubleViaWord64F :: FixedPrim Word64 -> FixedPrim Double +#if HS_CAST_FLOAT_WORD_OPS_AVAILABLE +encodeDoubleViaWord64F = (castDoubleToWord64 >$<) +#else +encodeDoubleViaWord64F w64fe = fixedPrim (size w64fe) $ \x op -> do + x' <- with x (peek . castPtr) + runF w64fe x' op +#endif diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/RealFloat.hs @@ -0,0 +1,287 @@ +-- | +-- Module : Data.ByteString.Builder.RealFloat +-- Copyright : (c) Lawrence Wu 2021 +-- License : BSD-style +-- Maintainer : lawrencejwu@gmail.com +-- +-- Floating point formatting for @Bytestring.Builder@ +-- +-- This module primarily exposes `floatDec` and `doubleDec` which do the +-- equivalent of converting through @'Data.ByteString.Builder.string7' . 'show'@. +-- +-- It also exposes `formatFloat` and `formatDouble` with a similar API as +-- `GHC.Float.formatRealFloat`. +-- +-- NB: The float-to-string conversions exposed by this module match `show`'s +-- output (specifically with respect to default rounding and length). In +-- particular, there are boundary cases where the closest and \'shortest\' +-- string representations are not used. Mentions of \'shortest\' in the docs +-- below are with this caveat. +-- +-- For example, for fidelity, we match `show` on the output below. +-- +-- >>> show (1.0e23 :: Float) +-- "1.0e23" +-- >>> show (1.0e23 :: Double) +-- "9.999999999999999e22" +-- >>> floatDec 1.0e23 +-- "1.0e23" +-- >>> doubleDec 1.0e23 +-- "9.999999999999999e22" +-- +-- Simplifying, we can build a shorter, lossless representation by just using +-- @"1.0e23"@ since the floating point values that are 1 ULP away are +-- +-- >>> showHex (castDoubleToWord64 1.0e23) [] +-- "44b52d02c7e14af6" +-- >>> castWord64ToDouble 0x44b52d02c7e14af5 +-- 9.999999999999997e22 +-- >>> castWord64ToDouble 0x44b52d02c7e14af6 +-- 9.999999999999999e22 +-- >>> castWord64ToDouble 0x44b52d02c7e14af7 +-- 1.0000000000000001e23 +-- +-- In particular, we could use the exact boundary if it is the shortest +-- representation and the original floating number is even. To experiment with +-- the shorter rounding, refer to +-- `Data.ByteString.Builder.RealFloat.Internal.acceptBounds`. This will give us +-- +-- >>> floatDec 1.0e23 +-- "1.0e23" +-- >>> doubleDec 1.0e23 +-- "1.0e23" +-- +-- For more details, please refer to the +-- . +-- +-- @since 0.11.2.0 + +module Data.ByteString.Builder.RealFloat + ( floatDec + , doubleDec + + -- * Custom formatting + , formatFloat + , formatDouble + , FloatFormat + , standard + , standardDefaultPrecision + , scientific + , generic + ) where + +import Data.ByteString.Builder.Internal (Builder) +import qualified Data.ByteString.Builder.RealFloat.Internal as R +import qualified Data.ByteString.Builder.RealFloat.F2S as RF +import qualified Data.ByteString.Builder.RealFloat.D2S as RD +import qualified Data.ByteString.Builder.Prim as BP +import GHC.Float (roundTo) +import GHC.Word (Word64) +import GHC.Show (intToDigit) + +-- | Returns a rendered Float. Matches `show` in displaying in standard or +-- scientific notation +-- +-- @ +-- floatDec = 'formatFloat' 'generic' +-- @ +{-# INLINABLE floatDec #-} +floatDec :: Float -> Builder +floatDec = formatFloat generic + +-- | Returns a rendered Double. Matches `show` in displaying in standard or +-- scientific notation +-- +-- @ +-- doubleDec = 'formatDouble' 'generic' +-- @ +{-# INLINABLE doubleDec #-} +doubleDec :: Double -> Builder +doubleDec = formatDouble generic + +-- | Format type for use with `formatFloat` and `formatDouble`. +-- +-- @since 0.11.2.0 +data FloatFormat = MkFloatFormat FormatMode (Maybe Int) + +-- | Standard notation with `n` decimal places +-- +-- @since 0.11.2.0 +standard :: Int -> FloatFormat +standard n = MkFloatFormat FStandard (Just n) + +-- | Standard notation with the \'default precision\' (decimal places matching `show`) +-- +-- @since 0.11.2.0 +standardDefaultPrecision :: FloatFormat +standardDefaultPrecision = MkFloatFormat FStandard Nothing + +-- | Scientific notation with \'default precision\' (decimal places matching `show`) +-- +-- @since 0.11.2.0 +scientific :: FloatFormat +scientific = MkFloatFormat FScientific Nothing + +-- | Standard or scientific notation depending on the exponent. Matches `show` +-- +-- @since 0.11.2.0 +generic :: FloatFormat +generic = MkFloatFormat FGeneric Nothing + +-- | ByteString float-to-string format +data FormatMode + = FScientific -- ^ scientific notation + | FStandard -- ^ standard notation with `Maybe Int` digits after the decimal + | FGeneric -- ^ dispatches to scientific or standard notation based on the exponent + deriving Show + +-- TODO: support precision argument for FGeneric and FScientific +-- | Returns a rendered Float. Returns the \'shortest\' representation in +-- scientific notation and takes an optional precision argument in standard +-- notation. Also see `floatDec`. +-- +-- With standard notation, the precision argument is used to truncate (or +-- extend with 0s) the \'shortest\' rendered Float. The \'default precision\' does +-- no such modifications and will return as many decimal places as the +-- representation demands. +-- +-- e.g +-- +-- >>> formatFloat (standard 1) 1.2345e-2 +-- "0.0" +-- >>> formatFloat (standard 10) 1.2345e-2 +-- "0.0123450000" +-- >>> formatFloat standardDefaultPrecision 1.2345e-2 +-- "0.01234" +-- >>> formatFloat scientific 12.345 +-- "1.2345e1" +-- >>> formatFloat generic 12.345 +-- "12.345" +-- +-- @since 0.11.2.0 +{-# INLINABLE formatFloat #-} +formatFloat :: FloatFormat -> Float -> Builder +formatFloat (MkFloatFormat fmt prec) = \f -> + let (RF.FloatingDecimal m e) = RF.f2Intermediate f + e' = R.int32ToInt e + R.decimalLength9 m in + case fmt of + FGeneric -> + case specialStr f of + Just b -> b + Nothing -> + if e' >= 0 && e' <= 7 + then sign f `mappend` showStandard (R.word32ToWord64 m) e' prec + else BP.primBounded (R.toCharsScientific (f < 0) m e) () + FScientific -> RF.f2s f + FStandard -> + case specialStr f of + Just b -> b + Nothing -> sign f `mappend` showStandard (R.word32ToWord64 m) e' prec + +-- TODO: support precision argument for FGeneric and FScientific +-- | Returns a rendered Double. Returns the \'shortest\' representation in +-- scientific notation and takes an optional precision argument in standard +-- notation. Also see `doubleDec`. +-- +-- With standard notation, the precision argument is used to truncate (or +-- extend with 0s) the \'shortest\' rendered Float. The \'default precision\' +-- does no such modifications and will return as many decimal places as the +-- representation demands. +-- +-- e.g +-- +-- >>> formatDouble (standard 1) 1.2345e-2 +-- "0.0" +-- >>> formatDouble (standard 10) 1.2345e-2 +-- "0.0123450000" +-- >>> formatDouble standardDefaultPrecision 1.2345e-2 +-- "0.01234" +-- >>> formatDouble scientific 12.345 +-- "1.2345e1" +-- >>> formatDouble generic 12.345 +-- "12.345" +-- +-- @since 0.11.2.0 +{-# INLINABLE formatDouble #-} +formatDouble :: FloatFormat -> Double -> Builder +formatDouble (MkFloatFormat fmt prec) = \f -> + let (RD.FloatingDecimal m e) = RD.d2Intermediate f + e' = R.int32ToInt e + R.decimalLength17 m in + case fmt of + FGeneric -> + case specialStr f of + Just b -> b + Nothing -> + if e' >= 0 && e' <= 7 + then sign f `mappend` showStandard m e' prec + else BP.primBounded (R.toCharsScientific (f < 0) m e) () + FScientific -> RD.d2s f + FStandard -> + case specialStr f of + Just b -> b + Nothing -> sign f `mappend` showStandard m e' prec + +-- | Char7 encode a 'Char'. +{-# INLINE char7 #-} +char7 :: Char -> Builder +char7 = BP.primFixed BP.char7 + +-- | Char7 encode a 'String'. +{-# INLINE string7 #-} +string7 :: String -> Builder +string7 = BP.primMapListFixed BP.char7 + +-- | Encodes a `-` if input is negative +sign :: RealFloat a => a -> Builder +sign f = if f < 0 then char7 '-' else mempty + +-- | Special rendering for Nan, Infinity, and 0. See +-- RealFloat.Internal.NonNumbersAndZero +specialStr :: RealFloat a => a -> Maybe Builder +specialStr f + | isNaN f = Just $ string7 "NaN" + | isInfinite f = Just $ sign f `mappend` string7 "Infinity" + | isNegativeZero f = Just $ string7 "-0.0" + | f == 0 = Just $ string7 "0.0" + | otherwise = Nothing + +-- | Returns a list of decimal digits in a Word64 +digits :: Word64 -> [Int] +digits w = go [] w + where go ds 0 = ds + go ds c = let (q, r) = R.dquotRem10 c + in go ((R.word64ToInt r) : ds) q + +-- | Show a floating point value in standard notation. Based on GHC.Float.showFloat +showStandard :: Word64 -> Int -> Maybe Int -> Builder +showStandard m e prec = + case prec of + Nothing + | e <= 0 -> char7 '0' + `mappend` char7 '.' + `mappend` string7 (replicate (-e) '0') + `mappend` mconcat (digitsToBuilder ds) + | otherwise -> + let f 0 s rs = mk0 (reverse s) `mappend` char7 '.' `mappend` mk0 rs + f n s [] = f (n-1) (char7 '0':s) [] + f n s (r:rs) = f (n-1) (r:s) rs + in f e [] (digitsToBuilder ds) + Just p + | e >= 0 -> + let (ei, is') = roundTo 10 (p' + e) ds + (ls, rs) = splitAt (e + ei) (digitsToBuilder is') + in mk0 ls `mappend` mkDot rs + | otherwise -> + let (ei, is') = roundTo 10 p' (replicate (-e) 0 ++ ds) + -- ds' should always be non-empty but use redundant pattern + -- matching to silence warning + ds' = if ei > 0 then is' else 0:is' + (ls, rs) = splitAt 1 $ digitsToBuilder ds' + in mk0 ls `mappend` mkDot rs + where p' = max p 0 + where + mk0 ls = case ls of [] -> char7 '0'; _ -> mconcat ls + mkDot rs = if null rs then mempty else char7 '.' `mappend` mconcat rs + ds = digits m + digitsToBuilder = fmap (char7 . intToDigit) + diff --git a/Data/ByteString/Builder/RealFloat/D2S.hs b/Data/ByteString/Builder/RealFloat/D2S.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/RealFloat/D2S.hs @@ -0,0 +1,863 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Data.ByteString.Builder.RealFloat.D2S +-- Copyright : (c) Lawrence Wu 2021 +-- License : BSD-style +-- Maintainer : lawrencejwu@gmail.com +-- +-- Implementation of double-to-string conversion + +module Data.ByteString.Builder.RealFloat.D2S + ( FloatingDecimal(..) + , d2s + , d2Intermediate + ) where + +import Control.Arrow (first) +import Data.Bits ((.|.), (.&.), unsafeShiftL, unsafeShiftR) +import Data.ByteString.Builder.Internal (Builder) +import Data.ByteString.Builder.Prim (primBounded) +import Data.ByteString.Builder.RealFloat.Internal +import Data.Maybe (fromMaybe) +import GHC.Int (Int32(..)) +import GHC.Word (Word64(..)) + +#if !PURE_HASKELL +import GHC.Ptr (Ptr(..)) +#endif + +-- See Data.ByteString.Builder.RealFloat.TableGenerator for a high-level +-- explanation of the ryu algorithm + +#if !PURE_HASKELL +-- | Table of 2^k / 5^q + 1 +-- +-- > splitWord128s $ fmap (finv double_pow5_inv_bitcount) [0..double_max_inv_split] +foreign import ccall "&hs_bytestring_double_pow5_inv_split" + double_pow5_inv_split :: Ptr Word64 + +-- | Table of 5^(-e2-q) / 2^k + 1 +-- +-- > splitWord128s $ fmap (fnorm double_pow5_bitcount) [0..double_max_split] +foreign import ccall "&hs_bytestring_double_pow5_split" + double_pow5_split :: Ptr Word64 +#endif + +-- | Number of mantissa bits of a 64-bit float. The number of significant bits +-- (floatDigits (undefined :: Double)) is 53 since we have a leading 1 for +-- normal floats and 0 for subnormal floats +double_mantissa_bits :: Int +double_mantissa_bits = 52 + +-- | Number of exponent bits of a 64-bit float +double_exponent_bits :: Int +double_exponent_bits = 11 + +-- | Bias in encoded 64-bit float representation (2^10 - 1) +double_bias :: Int +double_bias = 1023 + +data FloatingDecimal = FloatingDecimal + { dmantissa :: !Word64 + , dexponent :: !Int32 + } deriving (Show, Eq) + +-- | Quick check for small integers +d2dSmallInt :: Word64 -> Word64 -> Maybe FloatingDecimal +d2dSmallInt m e = + let m2 = (1 `unsafeShiftL` double_mantissa_bits) .|. m + e2 = word64ToInt e - (double_bias + double_mantissa_bits) + fraction = m2 .&. mask (-e2) + in case () of + _ -- f = m2 * 2^e2 >= 2^53 is an integer. + -- Ignore this case for now. + | e2 > 0 -> Nothing + -- f < 1 + | e2 < -52 -> Nothing + -- Since 2^52 <= m2 < 2^53 and 0 <= -e2 <= 52: + -- 1 <= f = m2 / 2^-e2 < 2^53. + -- Test if the lower -e2 bits of the significand are 0, i.e. + -- whether the fraction is 0. + | fraction /= 0 -> Nothing + -- f is an integer in the range [1, 2^53). + -- Note: mantissa might contain trailing (decimal) 0's. + -- Note: since 2^53 < 10^16, there is no need to adjust decimalLength17(). + | otherwise -> Just $ FloatingDecimal (m2 `unsafeShiftR` (-e2)) 0 + + +-- | Removes trailing (decimal) zeros for small integers in the range [1, 2^53) +unifySmallTrailing :: FloatingDecimal -> FloatingDecimal +unifySmallTrailing fd@(FloatingDecimal m e) = + let !(q, r) = dquotRem10 m + in if r == 0 + then unifySmallTrailing $ FloatingDecimal q (e + 1) + else fd + +-- TODO: 128-bit intrinsics +-- | Multiply a 64-bit number with a 128-bit number while keeping the upper 64 +-- bits. Then shift by specified amount minus 64 +mulShift64 :: Word64 -> (Word64, Word64) -> Int -> Word64 +mulShift64 m (factorHi, factorLo) shift = + let !(b0Hi, _ ) = m `timesWord2` factorLo + !(b1Hi, b1Lo) = m `timesWord2` factorHi + total = b0Hi + b1Lo + high = b1Hi + boolToWord64 (total < b0Hi) + dist = shift - 64 + in (high `unsafeShiftL` (64 - dist)) .|. (total `unsafeShiftR` dist) + +-- | Index into the 128-bit word lookup table double_pow5_inv_split +get_double_pow5_inv_split :: Int -> (Word64, Word64) +#if !PURE_HASKELL +get_double_pow5_inv_split = getWord128At double_pow5_inv_split +#else +-- > putStr $ case128 (finv double_pow5_inv_bitcount) [0..double_max_inv_split] +get_double_pow5_inv_split i = case i of + 0 -> (0x2000000000000000, 0x1) + 1 -> (0x1999999999999999, 0x999999999999999a) + 2 -> (0x147ae147ae147ae1, 0x47ae147ae147ae15) + 3 -> (0x10624dd2f1a9fbe7, 0x6c8b4395810624de) + 4 -> (0x1a36e2eb1c432ca5, 0x7a786c226809d496) + 5 -> (0x14f8b588e368f084, 0x61f9f01b866e43ab) + 6 -> (0x10c6f7a0b5ed8d36, 0xb4c7f34938583622) + 7 -> (0x1ad7f29abcaf4857, 0x87a6520ec08d236a) + 8 -> (0x15798ee2308c39df, 0x9fb841a566d74f88) + 9 -> (0x112e0be826d694b2, 0xe62d01511f12a607) + 10 -> (0x1b7cdfd9d7bdbab7, 0xd6ae6881cb5109a4) + 11 -> (0x15fd7fe17964955f, 0xdef1ed34a2a73aea) + 12 -> (0x119799812dea1119, 0x7f27f0f6e885c8bb) + 13 -> (0x1c25c268497681c2, 0x650cb4be40d60df8) + 14 -> (0x16849b86a12b9b01, 0xea70909833de7193) + 15 -> (0x1203af9ee756159b, 0x21f3a6e0297ec143) + 16 -> (0x1cd2b297d889bc2b, 0x6985d7cd0f313537) + 17 -> (0x170ef54646d49689, 0x2137dfd73f5a90f9) + 18 -> (0x12725dd1d243aba0, 0xe75fe645cc4873fa) + 19 -> (0x1d83c94fb6d2ac34, 0xa5663d3c7a0d865d) + 20 -> (0x179ca10c9242235d, 0x511e976394d79eb1) + 21 -> (0x12e3b40a0e9b4f7d, 0xda7edf82dd794bc1) + 22 -> (0x1e392010175ee596, 0x2a6498d1625bac68) + 23 -> (0x182db34012b25144, 0xeeb6e0a781e2f053) + 24 -> (0x1357c299a88ea76a, 0x58924d52ce4f26a9) + 25 -> (0x1ef2d0f5da7dd8aa, 0x27507bb7b07ea441) + 26 -> (0x18c240c4aecb13bb, 0x52a6c95fc0655034) + 27 -> (0x13ce9a36f23c0fc9, 0xeebd44c99eaa690) + 28 -> (0x1fb0f6be50601941, 0xb17953adc3110a80) + 29 -> (0x195a5efea6b34767, 0xc12ddc8b02740867) + 30 -> (0x14484bfeebc29f86, 0x3424b06f3529a052) + 31 -> (0x1039d66589687f9e, 0x901d59f290ee19db) + 32 -> (0x19f623d5a8a73297, 0x4cfbc31db4b0295f) + 33 -> (0x14c4e977ba1f5bac, 0x3d9635b15d59bab2) + 34 -> (0x109d8792fb4c4956, 0x97ab5e277de16228) + 35 -> (0x1a95a5b7f87a0ef0, 0xf2abc9d8c9689d0d) + 36 -> (0x154484932d2e725a, 0x5bbca17a3aba173e) + 37 -> (0x11039d428a8b8eae, 0xafca1ac82efb45cb) + 38 -> (0x1b38fb9daa78e44a, 0xb2dcf7a6b1920945) + 39 -> (0x15c72fb1552d836e, 0xf57d92ebc141a104) + 40 -> (0x116c262777579c58, 0xc46475896767b403) + 41 -> (0x1be03d0bf225c6f4, 0x6d6d88dbd8a5ecd2) + 42 -> (0x164cfda3281e38c3, 0x8abe071646eb23db) + 43 -> (0x11d7314f534b609c, 0x6efe6c11d255b649) + 44 -> (0x1c8b821885456760, 0xb197134fb6ef8a0e) + 45 -> (0x16d601ad376ab91a, 0x27ac0f72f8bfa1a5) + 46 -> (0x1244ce242c5560e1, 0xb95672c260994e1e) + 47 -> (0x1d3ae36d13bbce35, 0xf5571e03cdc21695) + 48 -> (0x17624f8a762fd82b, 0x2aac18030b01abab) + 49 -> (0x12b50c6ec4f31355, 0xbbbce0026f348956) + 50 -> (0x1dee7a4ad4b81eef, 0x92c7ccd0b1eda889) + 51 -> (0x17f1fb6f10934bf2, 0xdbd30a408e57ba07) + 52 -> (0x1327fc58da0f6ff5, 0x7ca8d50071dfc806) + 53 -> (0x1ea6608e29b24cbb, 0xfaa7bb33e9660cd6) + 54 -> (0x18851a0b548ea3c9, 0x9552fc298784d711) + 55 -> (0x139dae6f76d88307, 0xaaa8c9bad2d0ac0e) + 56 -> (0x1f62b0b257c0d1a5, 0xdddadc5e1e1aace3) + 57 -> (0x191bc08eac9a4151, 0x7e48b04b4b488a4f) + 58 -> (0x141633a556e1cdda, 0xcb6d59d5d5d3a1d9) + 59 -> (0x1011c2eaabe7d7e2, 0x3c577b1177dc817b) + 60 -> (0x19b604aaaca62636, 0xc6f25e825960cf2a) + 61 -> (0x14919d5556eb51c5, 0x6bf518684780a5bb) + 62 -> (0x10747ddddf22a7d1, 0x232a79ed06008496) + 63 -> (0x1a53fc9631d10c81, 0xd1dd8fe1a3340756) + 64 -> (0x150ffd44f4a73d34, 0xa7e4731ae8f66c45) + 65 -> (0x10d9976a5d52975d, 0x531d28e253f8569e) + 66 -> (0x1af5bf109550f22e, 0xeb61db03b98d5762) + 67 -> (0x159165a6ddda5b58, 0xbc4e48cfc7a445e8) + 68 -> (0x11411e1f17e1e2ad, 0x6371d3d96c836b20) + 69 -> (0x1b9b6364f3030448, 0x9f1c8628ad9f11cd) + 70 -> (0x1615e91d8f359d06, 0xe5b06b53be18db0b) + 71 -> (0x11ab20e472914a6b, 0xeaf3890fcb4715a2) + 72 -> (0x1c45016d841baa46, 0x44b8db4c7871bc37) + 73 -> (0x169d9abe03495505, 0x3c715d6c6c1635f) + 74 -> (0x1217aefe69077737, 0x3638de456bcde919) + 75 -> (0x1cf2b1970e725858, 0x56c163a2461641c1) + 76 -> (0x17288e1271f51379, 0xdf011c81d1ab67ce) + 77 -> (0x1286d80ec190dc61, 0x7f3416ce4155eca5) + 78 -> (0x1da48ce468e7c702, 0x6520247d3556476e) + 79 -> (0x17b6d71d20b96c01, 0xea801d30f7783925) + 80 -> (0x12f8ac174d612334, 0xbb99b0f3f92cfa84) + 81 -> (0x1e5aacf215683854, 0x5f5c4e532847f739) + 82 -> (0x18488a5b44536043, 0x7f7d0b75b9d32c2e) + 83 -> (0x136d3b7c36a919cf, 0x9930d5f7c7dc2358) + 84 -> (0x1f152bf9f10e8fb2, 0x8eb4898c72f9d226) + 85 -> (0x18ddbcc7f40ba628, 0x722a07a38f2e41b8) + 86 -> (0x13e497065cd61e86, 0xc1bb394fa5be9afa) + 87 -> (0x1fd424d6faf030d7, 0x9c5ec2190930f7f6) + 88 -> (0x197683df2f268d79, 0x49e56814075a5ff8) + 89 -> (0x145ecfe5bf520ac7, 0x6e51201005e1e660) + 90 -> (0x104bd984990e6f05, 0xf1da800cd181851a) + 91 -> (0x1a12f5a0f4e3e4d6, 0x4fc400148268d4f5) + 92 -> (0x14dbf7b3f71cb711, 0xd96999aa01ed772b) + 93 -> (0x10aff95cc5b09274, 0xadee1488018ac5bc) + 94 -> (0x1ab328946f80ea54, 0x497ceda668de092c) + 95 -> (0x155c2076bf9a5510, 0x3aca57b853e4d424) + 96 -> (0x1116805effaeaa73, 0x623b7960431d7683) + 97 -> (0x1b5733cb32b110b8, 0x9d2bf566d1c8bd9e) + 98 -> (0x15df5ca28ef40d60, 0x7dbcc452416d647f) + 99 -> (0x117f7d4ed8c33de6, 0xcafd69db678ab6cc) + 100 -> (0x1bff2ee48e052fd7, 0xab2f0fc572778adf) + 101 -> (0x1665bf1d3e6a8cac, 0x88f273045b92d580) + 102 -> (0x11eaff4a98553d56, 0xd3f528d049424466) + 103 -> (0x1cab3210f3bb9557, 0xb988414d4203a0a3) + 104 -> (0x16ef5b40c2fc7779, 0x6139cdd76802e6e9) + 105 -> (0x125915cd68c9f92d, 0xe761717920025254) + 106 -> (0x1d5b561574765b7c, 0xa568b58e999d5086) + 107 -> (0x177c44ddf6c515fd, 0x5120913ee14aa6d2) + 108 -> (0x12c9d0b1923744ca, 0xa74d40ff1aa21f0e) + 109 -> (0x1e0fb44f50586e11, 0xbaece64f769cb4a) + 110 -> (0x180c903f7379f1a7, 0x3c8bd850c5ee3c3b) + 111 -> (0x133d4032c2c7f485, 0xca0979da37f1c9c9) + 112 -> (0x1ec866b79e0cba6f, 0xa9a8c2f6bfe942db) + 113 -> (0x18a0522c7e709526, 0x2153cf2bccba9be3) + 114 -> (0x13b374f06526ddb8, 0x1aa9728970954982) + 115 -> (0x1f8587e7083e2f8c, 0xf775840f1a88759d) + 116 -> (0x19379fec0698260a, 0x5f9136727ba05e17) + 117 -> (0x142c7ff0054684d5, 0x1940f85b9619e4df) + 118 -> (0x1023998cd1053710, 0xe100c6afab47ea4c) + 119 -> (0x19d28f47b4d524e7, 0xce67a44c453fdd47) + 120 -> (0x14a8729fc3ddb71f, 0xd852e9d69dccb106) + 121 -> (0x1086c219697e2c19, 0x79dbee454b0a2738) + 122 -> (0x1a71368f0f30468f, 0x295fe3a211a9d859) + 123 -> (0x15275ed8d8f36ba5, 0xbab31c81a7bb137a) + 124 -> (0x10ec4be0ad8f8951, 0x6228e39aec95a92f) + 125 -> (0x1b13ac9aaf4c0ee8, 0x9d0e38f7e0ef7517) + 126 -> (0x15a956e225d67253, 0xb0d82d931a592a79) + 127 -> (0x11544581b7dec1dc, 0x8d79be0f4847552e) + 128 -> (0x1bba08cf8c979c94, 0x158f967eda0bbb7c) + 129 -> (0x162e6d72d6dfb076, 0x77a611ff14d62f97) + 130 -> (0x11bebdf578b2f391, 0xf951a7ff43de8c79) + 131 -> (0x1c6463225ab7ec1c, 0xc21c3ffed2fdad8e) + 132 -> (0x16b6b5b5155ff017, 0x1b0333242648ad8) + 133 -> (0x122bc490dde659ac, 0x159c28e9b83a246) + 134 -> (0x1d12d41afca3c2ac, 0xcef604175f3903a3) + 135 -> (0x17424348ca1c9bbd, 0x725e69ac4c2d9c83) + 136 -> (0x129b69070816e2fd, 0xf5185489d68ae39c) + 137 -> (0x1dc574d80cf16b2f, 0xee8d540fbdab05c6) + 138 -> (0x17d12a4670c1228c, 0xbed77672fe226b05) + 139 -> (0x130dbb6b8d674ed6, 0xff12c528cb4ebc04) + 140 -> (0x1e7c5f127bd87e24, 0xcb513b74787df9a0) + 141 -> (0x18637f41fcad31b7, 0x90dc929f9fe614d) + 142 -> (0x1382cc34ca2427c5, 0xa0d7d42194cb810a) + 143 -> (0x1f37ad21436d0c6f, 0x67bfb9cf5478ce77) + 144 -> (0x18f9574dcf8a7059, 0x1fcc94a5dd2d71f9) + 145 -> (0x13faac3e3fa1f37a, 0x7fd6dd517dbdf4c7) + 146 -> (0x1ff779fd329cb8c3, 0xffbe2ee8c92fee0b) + 147 -> (0x1992c7fdc216fa36, 0x6631bf20a0f324d6) + 148 -> (0x14756ccb01abfb5e, 0xb827cc1a1a5c1d78) + 149 -> (0x105df0a267bcc918, 0x935309ae7b7ce460) + 150 -> (0x1a2fe76a3f9474f4, 0x1eeb42b0c594a099) + 151 -> (0x14f31f8832dd2a5c, 0xe58902270476e6e1) + 152 -> (0x10c27fa028b0eeb0, 0xb7a0ce859d2bebe7) + 153 -> (0x1ad0cc33744e4ab4, 0x59014a6f61dfdfd8) + 154 -> (0x1573d68f903ea229, 0xe0cdd525e7e64cad) + 155 -> (0x11297872d9cbb4ee, 0x4d7177518651d6f1) + 156 -> (0x1b758d848fac54b0, 0x7be8bee8d6e957e8) + 157 -> (0x15f7a46a0c89dd59, 0xfcba3253df211320) + 158 -> (0x1192e9ee706e4aae, 0x63c8284318e74280) + 159 -> (0x1c1e43171a4a1117, 0x60d0d3827d86a66) + 160 -> (0x167e9c127b6e7412, 0x6b3da42cecad21eb) + 161 -> (0x11fee341fc585cdb, 0x88fe1cf0bd574e56) + 162 -> (0x1ccb0536608d615f, 0x419694b462254a23) + 163 -> (0x1708d0f84d3de77f, 0x67abaa29e81dd4e9) + 164 -> (0x126d73f9d764b932, 0xb95621bb2017dd87) + 165 -> (0x1d7becc2f23ac1ea, 0xc223692b668c95a5) + 166 -> (0x179657025b6234bb, 0xce82ba891ed6de1d) + 167 -> (0x12deac01e2b4f6fc, 0xa53562074bdf1818) + 168 -> (0x1e3113363787f194, 0x3b889cd87964f359) + 169 -> (0x18274291c6065adc, 0xfc6d4a46c783f5e1) + 170 -> (0x13529ba7d19eaf17, 0x30576e9f06032b1a) + 171 -> (0x1eea92a61c311825, 0x1a257dcb3cd1de90) + 172 -> (0x18bba884e35a79b7, 0x481dfe3c30a7e540) + 173 -> (0x13c9539d82aec7c5, 0xd34b31c9c0865100) + 174 -> (0x1fa885c8d117a609, 0x5211e942cda3b4cd) + 175 -> (0x19539e3a40dfb807, 0x74db21023e1c90a4) + 176 -> (0x1442e4fb67196005, 0xf715b401cb4a0d50) + 177 -> (0x103583fc527ab337, 0xf8de299b09080aa7) + 178 -> (0x19ef3993b72ab859, 0x8e304291a80cddd7) + 179 -> (0x14bf6142f8eef9e1, 0x3e8d020e200a4b13) + 180 -> (0x10991a9bfa58c7e7, 0x653d9b3e80083c0f) + 181 -> (0x1a8e90f9908e0ca5, 0x6ec8f864000d2ce4) + 182 -> (0x153eda614071a3b7, 0x8bd3f9e999a423ea) + 183 -> (0x10ff151a99f482f9, 0x3ca994bae1501cbb) + 184 -> (0x1b31bb5dc320d18e, 0xc775bac49bb3612b) + 185 -> (0x15c162b168e70e0b, 0xd2c4956a16291a89) + 186 -> (0x11678227871f3e6f, 0xdbd0778811ba7ba1) + 187 -> (0x1bd8d03f3e9863e6, 0x2c80bf401c5d929b) + 188 -> (0x16470cff6546b651, 0xbd33cc3349e47549) + 189 -> (0x11d270cc51055ea7, 0xca8fd68f6e505dd4) + 190 -> (0x1c83e7ad4e6efdd9, 0x4419574be3b3c953) + 191 -> (0x16cfec8aa52597e1, 0x347790982f63aa9) + 192 -> (0x123ff06eea847980, 0xcf6c60d468c4fbba) + 193 -> (0x1d331a4b10d3f59a, 0xe57a34870e07f92a) + 194 -> (0x175c1508da432ae2, 0x512e906c0b399422) + 195 -> (0x12b010d3e1cf5581, 0xda8ba6bcd5c7a9b5) + 196 -> (0x1de6815302e5559c, 0x90df712e22d90f87) + 197 -> (0x17eb9aa8cf1dde16, 0xda4c5a8b4f140c6c) + 198 -> (0x1322e220a5b17e78, 0xaea37ba2a5a9a38a) + 199 -> (0x1e9e369aa2b59727, 0x7dd25f6aa2a905a9) + 200 -> (0x187e92154ef7ac1f, 0x97db7f888220d154) + 201 -> (0x139874ddd8c6234c, 0x797c6606ce80a777) + 202 -> (0x1f5a549627a36bad, 0x8f2d700ae4010bf1) + 203 -> (0x191510781fb5efbe, 0xc2459a25000d65a) + 204 -> (0x1410d9f9b2f7f2fe, 0x701d1481d99a4515) + 205 -> (0x100d7b2e28c65bfe, 0xc017439b147b6a77) + 206 -> (0x19af2b7d0e0a2cca, 0xccf205c4ed9243f2) + 207 -> (0x148c22ca71a1bd6f, 0xa5b37d0be0e9cc2) + 208 -> (0x10701bd527b4978c, 0x848f973cb3ee3ce) + 209 -> (0x1a4cf9550c5425ac, 0xda0e5bec78649fb0) + 210 -> (0x150a6110d6a9b7bd, 0x7b3eaff060507fc0) + 211 -> (0x10d51a73deee2c97, 0x95cbbff380406633) + 212 -> (0x1aee90b964b04758, 0xefac665266cd7052) + 213 -> (0x158ba6fab6f36c47, 0x2623850eb8a459db) + 214 -> (0x113c85955f29236c, 0x1e82d0d893b6ae49) + 215 -> (0x1b9408eefea838ac, 0xfd9e1af41f8ab075) + 216 -> (0x16100725988693bd, 0x97b1af29b2d559f7) + 217 -> (0x11a66c1e139edc97, 0xac8e25baf5777b2c) + 218 -> (0x1c3d79c9b8fe2dbf, 0x7a7d092b2258c513) + 219 -> (0x169794a160cb57cc, 0x61fda0ef4ead6a76) + 220 -> (0x1212dd4de7091309, 0xe7fe1a590bbdeec5) + 221 -> (0x1ceafbafd80e84dc, 0xa6635d5b45fcb13a) + 222 -> (0x172262f3133ed0b0, 0x851c4aaf6b308dc8) + 223 -> (0x1281e8c275cbda26, 0xd0e36ef2bc26d7d4) + 224 -> (0x1d9ca79d894629d7, 0xb49f17eac6a48c86) + 225 -> (0x17b08617a104ee46, 0x2a18dfef0550706b) + 226 -> (0x12f39e794d9d8b6b, 0x54e0b3259dd9f389) + 227 -> (0x1e5297287c2f4578, 0x87cdeb6f62f65274) + 228 -> (0x18421286c9bf6ac6, 0xd30b22bf825ea85d) + 229 -> (0x13680ed23aff889f, 0xf3c1bcc684bb9e4) + 230 -> (0x1f0ce4839198da98, 0x18602c7a4079296d) + 231 -> (0x18d71d360e13e213, 0x46b356c833942124) + 232 -> (0x13df4a91a4dcb4dc, 0x388f78a029434db6) + 233 -> (0x1fcbaa82a1612160, 0x5a7f2766a86baf8a) + 234 -> (0x196fbb9bb44db44d, 0x153285ebb9efbfa2) + 235 -> (0x145962e2f6a4903d, 0xaa8ed189618c994e) + 236 -> (0x1047824f2bb6d9ca, 0xeed8a7a11ad6e10c) + 237 -> (0x1a0c03b1df8af611, 0x7e27729b5e249b45) + 238 -> (0x14d6695b193bf80d, 0xfe85f549181d4904) + 239 -> (0x10ab877c142ff9a4, 0xcb9e5dd4134aa0d0) + 240 -> (0x1aac0bf9b9e65c3a, 0xdf63c9535211014d) + 241 -> (0x15566ffafb1eb02f, 0x191ca10f74da6771) + 242 -> (0x1111f32f2f4bc025, 0xadb080d92a4852c1) + 243 -> (0x1b4feb7eb212cd09, 0x15e7348eaa0d5134) + 244 -> (0x15d98932280f0a6d, 0xab1f5d3eee710dc4) + 245 -> (0x117ad428200c0857, 0xbc1917658b8da49d) + 246 -> (0x1bf7b9d9cce00d59, 0x2cf4f23c127c3a94) + 247 -> (0x165fc7e170b33de0, 0xf0c3f4fcdb969543) + 248 -> (0x11e6398126f5cb1a, 0x5a365d9716121103) + 249 -> (0x1ca38f350b22de90, 0x9056fc24f01ce804) + 250 -> (0x16e93f5da2824ba6, 0xd9df301d8ce3ecd0) + 251 -> (0x125432b14ecea2eb, 0xe17f59b13d8323da) + 252 -> (0x1d53844ee47dd179, 0x68cbc2b52f38395c) + 253 -> (0x177603725064a794, 0x53d6355dbf602de3) + 254 -> (0x12c4cf8ea6b6ec76, 0xa9782ab165e68b1c) + 255 -> (0x1e07b27dd78b13f1, 0xf26aab56fd744fa) + 256 -> (0x18062864ac6f4327, 0x3f52222abfdf6a62) + 257 -> (0x1338205089f29c1f, 0x65db4e88997f884e) + 258 -> (0x1ec033b40fea9365, 0x6fc54a7428cc0d4a) + 259 -> (0x1899c2f673220f84, 0x596aa1f68709a43b) + 260 -> (0x13ae3591f5b4d936, 0xadeee7f86c07b696) + 261 -> (0x1f7d228322baf524, 0x497e3ff3e00c5756) + 262 -> (0x1930e868e89590e9, 0xd464fff64cd6ac45) + 263 -> (0x14272053ed4473ee, 0x4383fff83d7889d1) + 264 -> (0x101f4d0ff1038ff1, 0xcf9cccc69793a174) + 265 -> (0x19cbae7fe805b31c, 0x7f6147a425b90252) + 266 -> (0x14a2f1ffecd15c16, 0xcc4dd2e9b7c7350f) + 267 -> (0x10825b3323dab012, 0x3d0b0f215fd290d9) + 268 -> (0x1a6a2b85062ab350, 0x61ab4b689950e7c1) + 269 -> (0x1521bc6a6b555c40, 0x4e22a2ba1440b967) + 270 -> (0x10e7c9eebc4449cd, 0xb4ee894dd009453) + 271 -> (0x1b0c764ac6d3a948, 0x1217da87c800ed51) + 272 -> (0x15a391d56bdc876c, 0xdb46486ca000bdda) + 273 -> (0x114fa7ddefe39f8a, 0x490506bd4ccd64af) + 274 -> (0x1bb2a62fe638ff43, 0xa8080ac87ae23ab1) + 275 -> (0x162884f31e93ff69, 0x5339a239fbe82ef4) + 276 -> (0x11ba03f5b20fff87, 0x75c7b4fb2fecf25d) + 277 -> (0x1c5cd322b67fff3f, 0x22d92191e647ea2e) + 278 -> (0x16b0a8e891ffff65, 0xb57a8141850654f2) + 279 -> (0x1226ed86db3332b7, 0xc4620101373843f5) + 280 -> (0x1d0b15a491eb8459, 0x3a366801f1f39fee) + 281 -> (0x173c115074bc69e0, 0xfb5eb99b27f6198b) + 282 -> (0x129674405d6387e7, 0x2f7efae2865e7ad6) + 283 -> (0x1dbd86cd6238d971, 0xe597f7d0d6fd9156) + 284 -> (0x17cad23de82d7ac1, 0x8479930d78cadaab) + 285 -> (0x1308a831868ac89a, 0xd06142712d6f1556) + 286 -> (0x1e74404f3daada91, 0x4d686a4eaf182222) + 287 -> (0x185d003f6488aeda, 0xa453883ef279b4e8) + 288 -> (0x137d99cc506d58ae, 0xe9dc6cff28615d87) + 289 -> (0x1f2f5c7a1a488de4, 0xa960ae650d6895a4) + 290 -> (0x18f2b061aea07183, 0xbab3beb73ded4483) + _ -> (0x13f559e7bee6c136, 0x2ef6322c318a9d36) +#endif + +-- | Index into the 128-bit word lookup table double_pow5_split +get_double_pow5_split :: Int -> (Word64, Word64) +#if !PURE_HASKELL +get_double_pow5_split = getWord128At double_pow5_split +#else +-- > putStr $ case128 (fnorm double_pow5_bitcount) [0..double_max_split] +get_double_pow5_split i = case i of + 0 -> (0x1000000000000000, 0x0) + 1 -> (0x1400000000000000, 0x0) + 2 -> (0x1900000000000000, 0x0) + 3 -> (0x1f40000000000000, 0x0) + 4 -> (0x1388000000000000, 0x0) + 5 -> (0x186a000000000000, 0x0) + 6 -> (0x1e84800000000000, 0x0) + 7 -> (0x1312d00000000000, 0x0) + 8 -> (0x17d7840000000000, 0x0) + 9 -> (0x1dcd650000000000, 0x0) + 10 -> (0x12a05f2000000000, 0x0) + 11 -> (0x174876e800000000, 0x0) + 12 -> (0x1d1a94a200000000, 0x0) + 13 -> (0x12309ce540000000, 0x0) + 14 -> (0x16bcc41e90000000, 0x0) + 15 -> (0x1c6bf52634000000, 0x0) + 16 -> (0x11c37937e0800000, 0x0) + 17 -> (0x16345785d8a00000, 0x0) + 18 -> (0x1bc16d674ec80000, 0x0) + 19 -> (0x1158e460913d0000, 0x0) + 20 -> (0x15af1d78b58c4000, 0x0) + 21 -> (0x1b1ae4d6e2ef5000, 0x0) + 22 -> (0x10f0cf064dd59200, 0x0) + 23 -> (0x152d02c7e14af680, 0x0) + 24 -> (0x1a784379d99db420, 0x0) + 25 -> (0x108b2a2c28029094, 0x0) + 26 -> (0x14adf4b7320334b9, 0x0) + 27 -> (0x19d971e4fe8401e7, 0x4000000000000000) + 28 -> (0x1027e72f1f128130, 0x8800000000000000) + 29 -> (0x1431e0fae6d7217c, 0xaa00000000000000) + 30 -> (0x193e5939a08ce9db, 0xd480000000000000) + 31 -> (0x1f8def8808b02452, 0xc9a0000000000000) + 32 -> (0x13b8b5b5056e16b3, 0xbe04000000000000) + 33 -> (0x18a6e32246c99c60, 0xad85000000000000) + 34 -> (0x1ed09bead87c0378, 0xd8e6400000000000) + 35 -> (0x13426172c74d822b, 0x878fe80000000000) + 36 -> (0x1812f9cf7920e2b6, 0x6973e20000000000) + 37 -> (0x1e17b84357691b64, 0x3d0da8000000000) + 38 -> (0x12ced32a16a1b11e, 0x8262889000000000) + 39 -> (0x178287f49c4a1d66, 0x22fb2ab400000000) + 40 -> (0x1d6329f1c35ca4bf, 0xabb9f56100000000) + 41 -> (0x125dfa371a19e6f7, 0xcb54395ca0000000) + 42 -> (0x16f578c4e0a060b5, 0xbe2947b3c8000000) + 43 -> (0x1cb2d6f618c878e3, 0x2db399a0ba000000) + 44 -> (0x11efc659cf7d4b8d, 0xfc90400474400000) + 45 -> (0x166bb7f0435c9e71, 0x7bb4500591500000) + 46 -> (0x1c06a5ec5433c60d, 0xdaa16406f5a40000) + 47 -> (0x118427b3b4a05bc8, 0xa8a4de8459868000) + 48 -> (0x15e531a0a1c872ba, 0xd2ce16256fe82000) + 49 -> (0x1b5e7e08ca3a8f69, 0x87819baecbe22800) + 50 -> (0x111b0ec57e6499a1, 0xf4b1014d3f6d5900) + 51 -> (0x1561d276ddfdc00a, 0x71dd41a08f48af40) + 52 -> (0x1aba4714957d300d, 0xe549208b31adb10) + 53 -> (0x10b46c6cdd6e3e08, 0x28f4db456ff0c8ea) + 54 -> (0x14e1878814c9cd8a, 0x33321216cbecfb24) + 55 -> (0x1a19e96a19fc40ec, 0xbffe969c7ee839ed) + 56 -> (0x105031e2503da893, 0xf7ff1e21cf512434) + 57 -> (0x14643e5ae44d12b8, 0xf5fee5aa43256d41) + 58 -> (0x197d4df19d605767, 0x337e9f14d3eec892) + 59 -> (0x1fdca16e04b86d41, 0x5e46da08ea7ab6) + 60 -> (0x13e9e4e4c2f34448, 0xa03aec4845928cb2) + 61 -> (0x18e45e1df3b0155a, 0xc849a75a56f72fde) + 62 -> (0x1f1d75a5709c1ab1, 0x7a5c1130ecb4fbd6) + 63 -> (0x13726987666190ae, 0xec798abe93f11d65) + 64 -> (0x184f03e93ff9f4da, 0xa797ed6e38ed64bf) + 65 -> (0x1e62c4e38ff87211, 0x517de8c9c728bdef) + 66 -> (0x12fdbb0e39fb474a, 0xd2eeb17e1c7976b5) + 67 -> (0x17bd29d1c87a191d, 0x87aa5ddda397d462) + 68 -> (0x1dac74463a989f64, 0xe994f5550c7dc97b) + 69 -> (0x128bc8abe49f639f, 0x11fd195527ce9ded) + 70 -> (0x172ebad6ddc73c86, 0xd67c5faa71c24568) + 71 -> (0x1cfa698c95390ba8, 0x8c1b77950e32d6c2) + 72 -> (0x121c81f7dd43a749, 0x57912abd28dfc639) + 73 -> (0x16a3a275d494911b, 0xad75756c7317b7c8) + 74 -> (0x1c4c8b1349b9b562, 0x98d2d2c78fdda5ba) + 75 -> (0x11afd6ec0e14115d, 0x9f83c3bcb9ea8794) + 76 -> (0x161bcca7119915b5, 0x764b4abe8652979) + 77 -> (0x1ba2bfd0d5ff5b22, 0x493de1d6e27e73d7) + 78 -> (0x1145b7e285bf98f5, 0x6dc6ad264d8f0866) + 79 -> (0x159725db272f7f32, 0xc938586fe0f2ca80) + 80 -> (0x1afcef51f0fb5eff, 0x7b866e8bd92f7d20) + 81 -> (0x10de1593369d1b5f, 0xad34051767bdae34) + 82 -> (0x15159af804446237, 0x9881065d41ad19c1) + 83 -> (0x1a5b01b605557ac5, 0x7ea147f492186032) + 84 -> (0x1078e111c3556cbb, 0x6f24ccf8db4f3c1f) + 85 -> (0x14971956342ac7ea, 0x4aee003712230b27) + 86 -> (0x19bcdfabc13579e4, 0xdda98044d6abcdf0) + 87 -> (0x10160bcb58c16c2f, 0xa89f02b062b60b6) + 88 -> (0x141b8ebe2ef1c73a, 0xcd2c6c35c7b638e4) + 89 -> (0x1922726dbaae3909, 0x8077874339a3c71d) + 90 -> (0x1f6b0f092959c74b, 0xe0956914080cb8e4) + 91 -> (0x13a2e965b9d81c8f, 0x6c5d61ac8507f38e) + 92 -> (0x188ba3bf284e23b3, 0x4774ba17a649f072) + 93 -> (0x1eae8caef261aca0, 0x1951e89d8fdc6c8f) + 94 -> (0x132d17ed577d0be4, 0xfd3316279e9c3d9) + 95 -> (0x17f85de8ad5c4edd, 0x13c7fdbb186434cf) + 96 -> (0x1df67562d8b36294, 0x58b9fd29de7d4203) + 97 -> (0x12ba095dc7701d9c, 0xb7743e3a2b0e4942) + 98 -> (0x17688bb5394c2503, 0xe5514dc8b5d1db92) + 99 -> (0x1d42aea2879f2e44, 0xdea5a13ae3465277) + 100 -> (0x1249ad2594c37ceb, 0xb2784c4ce0bf38a) + 101 -> (0x16dc186ef9f45c25, 0xcdf165f6018ef06d) + 102 -> (0x1c931e8ab871732f, 0x416dbf7381f2ac88) + 103 -> (0x11dbf316b346e7fd, 0x88e497a83137abd5) + 104 -> (0x1652efdc6018a1fc, 0xeb1dbd923d8596ca) + 105 -> (0x1be7abd3781eca7c, 0x25e52cf6cce6fc7d) + 106 -> (0x1170cb642b133e8d, 0x97af3c1a40105dce) + 107 -> (0x15ccfe3d35d80e30, 0xfd9b0b20d0147542) + 108 -> (0x1b403dcc834e11bd, 0x3d01cde904199292) + 109 -> (0x1108269fd210cb16, 0x462120b1a28ffb9b) + 110 -> (0x154a3047c694fddb, 0xd7a968de0b33fa82) + 111 -> (0x1a9cbc59b83a3d52, 0xcd93c3158e00f923) + 112 -> (0x10a1f5b813246653, 0xc07c59ed78c09bb6) + 113 -> (0x14ca732617ed7fe8, 0xb09b7068d6f0c2a3) + 114 -> (0x19fd0fef9de8dfe2, 0xdcc24c830cacf34c) + 115 -> (0x103e29f5c2b18bed, 0xc9f96fd1e7ec180f) + 116 -> (0x144db473335deee9, 0x3c77cbc661e71e13) + 117 -> (0x1961219000356aa3, 0x8b95beb7fa60e598) + 118 -> (0x1fb969f40042c54c, 0x6e7b2e65f8f91efe) + 119 -> (0x13d3e2388029bb4f, 0xc50cfcffbb9bb35f) + 120 -> (0x18c8dac6a0342a23, 0xb6503c3faa82a037) + 121 -> (0x1efb1178484134ac, 0xa3e44b4f95234844) + 122 -> (0x135ceaeb2d28c0eb, 0xe66eaf11bd360d2b) + 123 -> (0x183425a5f872f126, 0xe00a5ad62c839075) + 124 -> (0x1e412f0f768fad70, 0x980cf18bb7a47493) + 125 -> (0x12e8bd69aa19cc66, 0x5f0816f752c6c8dc) + 126 -> (0x17a2ecc414a03f7f, 0xf6ca1cb527787b13) + 127 -> (0x1d8ba7f519c84f5f, 0xf47ca3e2715699d7) + 128 -> (0x127748f9301d319b, 0xf8cde66d86d62026) + 129 -> (0x17151b377c247e02, 0xf7016008e88ba830) + 130 -> (0x1cda62055b2d9d83, 0xb4c1b80b22ae923c) + 131 -> (0x12087d4358fc8272, 0x50f91306f5ad1b65) + 132 -> (0x168a9c942f3ba30e, 0xe53757c8b318623f) + 133 -> (0x1c2d43b93b0a8bd2, 0x9e852dbadfde7acf) + 134 -> (0x119c4a53c4e69763, 0xa3133c94cbeb0cc1) + 135 -> (0x16035ce8b6203d3c, 0x8bd80bb9fee5cff1) + 136 -> (0x1b843422e3a84c8b, 0xaece0ea87e9f43ee) + 137 -> (0x1132a095ce492fd7, 0x4d40c9294f238a75) + 138 -> (0x157f48bb41db7bcd, 0x2090fb73a2ec6d12) + 139 -> (0x1adf1aea12525ac0, 0x68b53a508ba78856) + 140 -> (0x10cb70d24b7378b8, 0x417144725748b536) + 141 -> (0x14fe4d06de5056e6, 0x51cd958eed1ae283) + 142 -> (0x1a3de04895e46c9f, 0xe640faf2a8619b24) + 143 -> (0x1066ac2d5daec3e3, 0xefe89cd7a93d00f7) + 144 -> (0x14805738b51a74dc, 0xebe2c40d938c4134) + 145 -> (0x19a06d06e2611214, 0x26db7510f86f5181) + 146 -> (0x100444244d7cab4c, 0x9849292a9b4592f1) + 147 -> (0x1405552d60dbd61f, 0xbe5b73754216f7ad) + 148 -> (0x1906aa78b912cba7, 0xadf25052929cb598) + 149 -> (0x1f485516e7577e91, 0x996ee4673743e2ff) + 150 -> (0x138d352e5096af1a, 0xffe54ec0828a6ddf) + 151 -> (0x18708279e4bc5ae1, 0xbfdea270a32d0957) + 152 -> (0x1e8ca3185deb719a, 0x2fd64b0ccbf84bad) + 153 -> (0x1317e5ef3ab32700, 0x5de5eee7ff7b2f4c) + 154 -> (0x17dddf6b095ff0c0, 0x755f6aa1ff59fb1f) + 155 -> (0x1dd55745cbb7ecf0, 0x92b7454a7f3079e7) + 156 -> (0x12a5568b9f52f416, 0x5bb28b4e8f7e4c30) + 157 -> (0x174eac2e8727b11b, 0xf29f2e22335ddf3c) + 158 -> (0x1d22573a28f19d62, 0xef46f9aac035570b) + 159 -> (0x123576845997025d, 0xd58c5c0ab8215667) + 160 -> (0x16c2d4256ffcc2f5, 0x4aef730d6629ac01) + 161 -> (0x1c73892ecbfbf3b2, 0x9dab4fd0bfb41701) + 162 -> (0x11c835bd3f7d784f, 0xa28b11e277d08e60) + 163 -> (0x163a432c8f5cd663, 0x8b2dd65b15c4b1f9) + 164 -> (0x1bc8d3f7b3340bfc, 0x6df94bf1db35de77) + 165 -> (0x115d847ad000877d, 0xc4bbcf772901ab0a) + 166 -> (0x15b4e5998400a95d, 0x35eac354f34215cd) + 167 -> (0x1b221effe500d3b4, 0x8365742a30129b40) + 168 -> (0x10f5535fef208450, 0xd21f689a5e0ba108) + 169 -> (0x1532a837eae8a565, 0x6a742c0f58e894a) + 170 -> (0x1a7f5245e5a2cebe, 0x4851137132f22b9d) + 171 -> (0x108f936baf85c136, 0xed32ac26bfd75b42) + 172 -> (0x14b378469b673184, 0xa87f57306fcd3212) + 173 -> (0x19e056584240fde5, 0xd29f2cfc8bc07e97) + 174 -> (0x102c35f729689eaf, 0xa3a37c1dd7584f1e) + 175 -> (0x14374374f3c2c65b, 0x8c8c5b254d2e62e6) + 176 -> (0x1945145230b377f2, 0x6faf71eea079fb9f) + 177 -> (0x1f965966bce055ef, 0xb9b4e6a48987a87) + 178 -> (0x13bdf7e0360c35b5, 0x674111026d5f4c94) + 179 -> (0x18ad75d8438f4322, 0xc111554308b71fba) + 180 -> (0x1ed8d34e547313eb, 0x7155aa93cae4e7a8) + 181 -> (0x13478410f4c7ec73, 0x26d58a9c5ecf10c9) + 182 -> (0x1819651531f9e78f, 0xf08aed437682d4fb) + 183 -> (0x1e1fbe5a7e786173, 0xecada89454238a3a) + 184 -> (0x12d3d6f88f0b3ce8, 0x73ec895cb4963664) + 185 -> (0x1788ccb6b2ce0c22, 0x90e7abb3e1bbc3fd) + 186 -> (0x1d6affe45f818f2b, 0x352196a0da2ab4fd) + 187 -> (0x1262dfeebbb0f97b, 0x134fe24885ab11e) + 188 -> (0x16fb97ea6a9d37d9, 0xc1823dadaa715d65) + 189 -> (0x1cba7de5054485d0, 0x31e2cd19150db4bf) + 190 -> (0x11f48eaf234ad3a2, 0x1f2dc02fad2890f7) + 191 -> (0x1671b25aec1d888a, 0xa6f9303b9872b535) + 192 -> (0x1c0e1ef1a724eaad, 0x50b77c4a7e8f6282) + 193 -> (0x1188d357087712ac, 0x5272adae8f199d91) + 194 -> (0x15eb082cca94d757, 0x670f591a32e004f6) + 195 -> (0x1b65ca37fd3a0d2d, 0x40d32f60bf980633) + 196 -> (0x111f9e62fe44483c, 0x4883fd9c77bf03e0) + 197 -> (0x156785fbbdd55a4b, 0x5aa4fd0395aec4d8) + 198 -> (0x1ac1677aad4ab0de, 0x314e3c447b1a760e) + 199 -> (0x10b8e0acac4eae8a, 0xded0e5aaccf089c9) + 200 -> (0x14e718d7d7625a2d, 0x96851f15802cac3b) + 201 -> (0x1a20df0dcd3af0b8, 0xfc2666dae037d74a) + 202 -> (0x10548b68a044d673, 0x9d980048cc22e68e) + 203 -> (0x1469ae42c8560c10, 0x84fe005aff2ba032) + 204 -> (0x198419d37a6b8f14, 0xa63d8071bef6883e) + 205 -> (0x1fe52048590672d9, 0xcfcce08e2eb42a4e) + 206 -> (0x13ef342d37a407c8, 0x21e00c58dd309a70) + 207 -> (0x18eb0138858d09ba, 0x2a580f6f147cc10d) + 208 -> (0x1f25c186a6f04c28, 0xb4ee134ad99bf150) + 209 -> (0x137798f428562f99, 0x7114cc0ec80176d2) + 210 -> (0x18557f31326bbb7f, 0xcd59ff127a01d486) + 211 -> (0x1e6adefd7f06aa5f, 0xc0b07ed7188249a8) + 212 -> (0x1302cb5e6f642a7b, 0xd86e4f466f516e09) + 213 -> (0x17c37e360b3d351a, 0xce89e3180b25c98b) + 214 -> (0x1db45dc38e0c8261, 0x822c5bde0def3bee) + 215 -> (0x1290ba9a38c7d17c, 0xf15bb96ac8b58575) + 216 -> (0x1734e940c6f9c5dc, 0x2db2a7c57ae2e6d2) + 217 -> (0x1d022390f8b83753, 0x391f51b6d99ba086) + 218 -> (0x1221563a9b732294, 0x3b3931248014454) + 219 -> (0x16a9abc9424feb39, 0x4a077d6da019569) + 220 -> (0x1c5416bb92e3e607, 0x45c895cc9081fac3) + 221 -> (0x11b48e353bce6fc4, 0x8b9d5d9fda513cba) + 222 -> (0x1621b1c28ac20bb5, 0xae84b507d0e58be8) + 223 -> (0x1baa1e332d728ea3, 0x1a25e249c51eeee3) + 224 -> (0x114a52dffc679925, 0xf057ad6e1b33554d) + 225 -> (0x159ce797fb817f6f, 0x6c6d98c9a2002aa1) + 226 -> (0x1b04217dfa61df4b, 0x4788fefc0a803549) + 227 -> (0x10e294eebc7d2b8f, 0xcb59f5d8690214e) + 228 -> (0x151b3a2a6b9c7672, 0xcfe30734e83429a1) + 229 -> (0x1a6208b50683940f, 0x83dbc9022241340a) + 230 -> (0x107d457124123c89, 0xb2695da15568c086) + 231 -> (0x149c96cd6d16cbac, 0x1f03b509aac2f0a7) + 232 -> (0x19c3bc80c85c7e97, 0x26c4a24c1573acd1) + 233 -> (0x101a55d07d39cf1e, 0x783ae56f8d684c03) + 234 -> (0x1420eb449c8842e6, 0x16499ecb70c25f03) + 235 -> (0x19292615c3aa539f, 0x9bdc067e4cf2f6c4) + 236 -> (0x1f736f9b3494e887, 0x82d3081de02fb476) + 237 -> (0x13a825c100dd1154, 0xb1c3e512ac1dd0c9) + 238 -> (0x18922f31411455a9, 0xde34de57572544fc) + 239 -> (0x1eb6bafd91596b14, 0x55c215ed2cee963b) + 240 -> (0x133234de7ad7e2ec, 0xb5994db43c151de5) + 241 -> (0x17fec216198ddba7, 0xe2ffa1214b1a655e) + 242 -> (0x1dfe729b9ff15291, 0xdbbf89699de0feb6) + 243 -> (0x12bf07a143f6d39b, 0x2957b5e202ac9f31) + 244 -> (0x176ec98994f48881, 0xf3ada35a8357c6fe) + 245 -> (0x1d4a7bebfa31aaa2, 0x70990c31242db8bd) + 246 -> (0x124e8d737c5f0aa5, 0x865fa79eb69c9376) + 247 -> (0x16e230d05b76cd4e, 0xe7f791866443b854) + 248 -> (0x1c9abd04725480a2, 0xa1f575e7fd54a669) + 249 -> (0x11e0b622c774d065, 0xa53969b0fe54e801) + 250 -> (0x1658e3ab7952047f, 0xe87c41d3dea2202) + 251 -> (0x1bef1c9657a6859e, 0xd229b5248d64aa82) + 252 -> (0x117571ddf6c81383, 0x435a1136d85eea91) + 253 -> (0x15d2ce55747a1864, 0x143095848e76a536) + 254 -> (0x1b4781ead1989e7d, 0x193cbae5b2144e83) + 255 -> (0x110cb132c2ff630e, 0x2fc5f4cf8f4cb112) + 256 -> (0x154fdd7f73bf3bd1, 0xbbb77203731fdd56) + 257 -> (0x1aa3d4df50af0ac6, 0x2aa54e844fe7d4ac) + 258 -> (0x10a6650b926d66bb, 0xdaa75112b1f0e4eb) + 259 -> (0x14cffe4e7708c06a, 0xd15125575e6d1e26) + 260 -> (0x1a03fde214caf085, 0x85a56ead360865b0) + 261 -> (0x10427ead4cfed653, 0x7387652c41c53f8e) + 262 -> (0x14531e58a03e8be8, 0x50693e7752368f71) + 263 -> (0x1967e5eec84e2ee2, 0x64838e1526c4334e) + 264 -> (0x1fc1df6a7a61ba9a, 0xfda4719a70754022) + 265 -> (0x13d92ba28c7d14a0, 0xde86c70086494815) + 266 -> (0x18cf768b2f9c59c9, 0x162878c0a7db9a1a) + 267 -> (0x1f03542dfb83703b, 0x5bb296f0d1d280a1) + 268 -> (0x1362149cbd322625, 0x194f9e5683239064) + 269 -> (0x183a99c3ec7eafae, 0x5fa385ec23ec747e) + 270 -> (0x1e494034e79e5b99, 0xf78c67672ce7919d) + 271 -> (0x12edc82110c2f940, 0x3ab7c0a07c10bb02) + 272 -> (0x17a93a2954f3b790, 0x4965b0c89b14e9c3) + 273 -> (0x1d9388b3aa30a574, 0x5bbf1cfac1da2433) + 274 -> (0x127c35704a5e6768, 0xb957721cb92856a0) + 275 -> (0x171b42cc5cf60142, 0xe7ad4ea3e7726c48) + 276 -> (0x1ce2137f74338193, 0xa198a24ce14f075a) + 277 -> (0x120d4c2fa8a030fc, 0x44ff65700cd16498) + 278 -> (0x16909f3b92c83d3b, 0x563f3ecc1005bdbe) + 279 -> (0x1c34c70a777a4c8a, 0x2bcf0e7f14072d2e) + 280 -> (0x11a0fc668aac6fd6, 0x5b61690f6c847c3d) + 281 -> (0x16093b802d578bcb, 0xf239c35347a59b4c) + 282 -> (0x1b8b8a6038ad6ebe, 0xeec83428198f021f) + 283 -> (0x1137367c236c6537, 0x553d20990ff96153) + 284 -> (0x1585041b2c477e85, 0x2a8c68bf53f7b9a8) + 285 -> (0x1ae64521f7595e26, 0x752f82ef28f5a812) + 286 -> (0x10cfeb353a97dad8, 0x93db1d57999890b) + 287 -> (0x1503e602893dd18e, 0xb8d1e4ad7ffeb4e) + 288 -> (0x1a44df832b8d45f1, 0x8e7065dd8dffe622) + 289 -> (0x106b0bb1fb384bb6, 0xf9063faa78bfefd5) + 290 -> (0x1485ce9e7a065ea4, 0xb747cf9516efebca) + 291 -> (0x19a742461887f64d, 0xe519c37a5cabe6bd) + 292 -> (0x1008896bcf54f9f0, 0xaf301a2c79eb7036) + 293 -> (0x140aabc6c32a386c, 0xdafc20b798664c43) + 294 -> (0x190d56b873f4c688, 0x11bb28e57e7fdf54) + 295 -> (0x1f50ac6690f1f82a, 0x1629f31ede1fd72a) + 296 -> (0x13926bc01a973b1a, 0x4dda37f34ad3e67a) + 297 -> (0x187706b0213d09e0, 0xe150c5f01d88e019) + 298 -> (0x1e94c85c298c4c59, 0x19a4f76c24eb181f) + 299 -> (0x131cfd3999f7afb7, 0xb0071aa39712ef13) + 300 -> (0x17e43c8800759ba5, 0x9c08e14c7cd7aad8) + 301 -> (0x1ddd4baa0093028f, 0x30b199f9c0d958e) + 302 -> (0x12aa4f4a405be199, 0x61e6f003c1887d79) + 303 -> (0x1754e31cd072d9ff, 0xba60ac04b1ea9cd7) + 304 -> (0x1d2a1be4048f907f, 0xa8f8d705de65440d) + 305 -> (0x123a516e82d9ba4f, 0xc99b8663aaff4a88) + 306 -> (0x16c8e5ca239028e3, 0xbc0267fc95bf1d2a) + 307 -> (0x1c7b1f3cac74331c, 0xab0301fbbb2ee474) + 308 -> (0x11ccf385ebc89ff1, 0xeae1e13d54fd4ec9) + 309 -> (0x1640306766bac7ee, 0x659a598caa3ca27b) + 310 -> (0x1bd03c81406979e9, 0xff00efefd4cbcb1a) + 311 -> (0x116225d0c841ec32, 0x3f6095f5e4ff5ef0) + 312 -> (0x15baaf44fa52673e, 0xcf38bb735e3f36ac) + 313 -> (0x1b295b1638e7010e, 0x8306ea5035cf0457) + 314 -> (0x10f9d8ede39060a9, 0x11e4527221a162b6) + 315 -> (0x15384f295c7478d3, 0x565d670eaa09bb64) + 316 -> (0x1a8662f3b3919708, 0x2bf4c0d2548c2a3d) + 317 -> (0x1093fdd8503afe65, 0x1b78f88374d79a66) + 318 -> (0x14b8fd4e6449bdfe, 0x625736a4520d8100) + 319 -> (0x19e73ca1fd5c2d7d, 0xfaed044d6690e140) + 320 -> (0x103085e53e599c6e, 0xbcd422b0601a8cc8) + 321 -> (0x143ca75e8df0038a, 0x6c092b5c78212ffa) + 322 -> (0x194bd136316c046d, 0x70b763396297bf8) + 323 -> (0x1f9ec583bdc70588, 0x48ce53c07bb3daf6) + 324 -> (0x13c33b72569c6375, 0x2d80f4584d5068da) + _ -> (0x18b40a4eec437c52, 0x78e1316e60a48310) +#endif + +-- | Take the high bits of m * 5^-e2-q / 2^k / 2^q-k +mulPow5DivPow2 :: Word64 -> Int -> Int -> Word64 +mulPow5DivPow2 m i j = mulShift64 m (get_double_pow5_split i) j + +-- | Take the high bits of m * 2^k / 5^q / 2^-e2+q+k +mulPow5InvDivPow2 :: Word64 -> Int -> Int -> Word64 +mulPow5InvDivPow2 m q j = mulShift64 m (get_double_pow5_inv_split q) j + +-- | Handle case e2 >= 0 +d2dGT :: Int32 -> Word64 -> Word64 -> Word64 -> (BoundsState Word64, Int32) +d2dGT e2' u v w = + let e2 = int32ToInt e2' + q = log10pow2 e2 - fromEnum (e2 > 3) + -- k = B0 + log_2(5^q) + k = double_pow5_inv_bitcount + pow5bits q - 1 + i = -e2 + q + k + -- (u, v, w) * 2^k / 5^q / 2^-e2+q+k + u' = mulPow5InvDivPow2 u q i + v' = mulPow5InvDivPow2 v q i + w' = mulPow5InvDivPow2 w q i + !(vvTrailing, vuTrailing, vw') = + case () of + _ | q <= 21 && (drem5 v == 0) + -> (multipleOfPowerOf5 v q, False, w') + | q <= 21 && acceptBounds v + -> (False, multipleOfPowerOf5 u q, w') + | q <= 21 + -> (False, False, w' - boolToWord64 (multipleOfPowerOf5 w q)) + | otherwise + -> (False, False, w') + in (BoundsState u' v' vw' 0 vuTrailing vvTrailing, intToInt32 q) + +-- | Handle case e2 < 0 +d2dLT :: Int32 -> Word64 -> Word64 -> Word64 -> (BoundsState Word64, Int32) +d2dLT e2' u v w = + let e2 = int32ToInt e2' + q = log10pow5 (-e2) - fromEnum (-e2 > 1) + e10 = q + e2 + i = -e2 - q + -- k = log_2(5^-e2-q) - B1 + k = pow5bits i - double_pow5_bitcount + j = q - k + -- (u, v, w) * 5^-e2-q / 2^k / 2^q-k + u' = mulPow5DivPow2 u i j + v' = mulPow5DivPow2 v i j + w' = mulPow5DivPow2 w i j + !(vvTrailing, vuTrailing, vw') = + case () of + _ | q <= 1 && acceptBounds v + -> (True, v - u == 2, w') -- mmShift == 1 + | q <= 1 + -> (True, False, w' - 1) + | q < 63 + -> (multipleOfPowerOf2 v (q - 1), False, w') + | otherwise + -> (False, False, w') + in (BoundsState u' v' vw' 0 vuTrailing vvTrailing, intToInt32 e10) + +-- | Returns the decimal representation of the given mantissa and exponent of a +-- 64-bit Double using the ryu algorithm. +d2d :: Word64 -> Word64 -> FloatingDecimal +d2d m e = + let !mf = if e == 0 + then m + else (1 `unsafeShiftL` double_mantissa_bits) .|. m + !ef = intToInt32 $ if e == 0 + then 1 - (double_bias + double_mantissa_bits) + else word64ToInt e - (double_bias + double_mantissa_bits) + !e2 = ef - 2 + -- Step 2. 3-tuple (u, v, w) * 2**e2 + !u = 4 * mf - 1 - boolToWord64 (m /= 0 || e <= 1) + !v = 4 * mf + !w = 4 * mf + 2 + -- Step 3. convert to decimal power base + !(state, e10) = + if e2 >= 0 + then d2dGT e2 u v w + else d2dLT e2 u v w + -- Step 4: Find the shortest decimal representation in the interval of + -- valid representations. + !(output, removed) = + let rounded = closestCorrectlyRounded (acceptBounds v) + in first rounded $ if vvIsTrailingZeros state || vuIsTrailingZeros state + then trimTrailing state + else trimNoTrailing state + !e' = e10 + removed + in FloatingDecimal output e' + +-- | Split a Double into (sign, mantissa, exponent) +breakdown :: Double -> (Bool, Word64, Word64) +breakdown f = + let bits = castDoubleToWord64 f + sign = ((bits `unsafeShiftR` (double_mantissa_bits + double_exponent_bits)) .&. 1) /= 0 + mantissa = bits .&. mask double_mantissa_bits + expo = (bits `unsafeShiftR` double_mantissa_bits) .&. mask double_exponent_bits + in (sign, mantissa, expo) + +-- | Dispatches to `d2d` or `d2dSmallInt` and applies the given formatters +{-# INLINE d2s' #-} +d2s' :: (Bool -> Word64 -> Int32 -> a) -> (NonNumbersAndZero -> a) -> Double -> a +d2s' formatter specialFormatter d = + let (sign, mantissa, expo) = breakdown d + in if (expo == mask double_exponent_bits) || (expo == 0 && mantissa == 0) + then specialFormatter NonNumbersAndZero + { negative=sign + , exponent_all_one=expo > 0 + , mantissa_non_zero=mantissa > 0 } + else let v = unifySmallTrailing <$> d2dSmallInt mantissa expo + FloatingDecimal m e = fromMaybe (d2d mantissa expo) v + in formatter sign m e + +-- | Render a Double in scientific notation +d2s :: Double -> Builder +d2s d = primBounded (d2s' toCharsScientific toCharsNonNumbersAndZero d) () + +-- | Returns the decimal representation of a Double. NaN and Infinity will +-- return `FloatingDecimal 0 0` +d2Intermediate :: Double -> FloatingDecimal +d2Intermediate = d2s' (const FloatingDecimal) (const $ FloatingDecimal 0 0) diff --git a/Data/ByteString/Builder/RealFloat/F2S.hs b/Data/ByteString/Builder/RealFloat/F2S.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/RealFloat/F2S.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Data.ByteString.Builder.RealFloat.F2S +-- Copyright : (c) Lawrence Wu 2021 +-- License : BSD-style +-- Maintainer : lawrencejwu@gmail.com +-- +-- Implementation of float-to-string conversion + +module Data.ByteString.Builder.RealFloat.F2S + ( FloatingDecimal(..) + , f2s + , f2Intermediate + ) where + +import Control.Arrow (first) +import Data.Bits ((.|.), (.&.), unsafeShiftL, unsafeShiftR) +import Data.ByteString.Builder.Internal (Builder) +import Data.ByteString.Builder.Prim (primBounded) +import Data.ByteString.Builder.RealFloat.Internal +import GHC.Int (Int32(..)) +import GHC.Word (Word32(..), Word64(..)) + +#if !PURE_HASKELL +import GHC.Ptr (Ptr(..)) +#endif + +-- See Data.ByteString.Builder.RealFloat.TableGenerator for a high-level +-- explanation of the ryu algorithm + +#if !PURE_HASKELL +-- | Table of 2^k / 5^q + 1 +-- +-- > fmap (finv float_pow5_inv_bitcount) [0..float_max_inv_split] +foreign import ccall "&hs_bytestring_float_pow5_inv_split" + float_pow5_inv_split :: Ptr Word64 + +-- | Table of 5^(-e2-q) / 2^k + 1 +-- +-- > fmap (fnorm float_pow5_bitcount) [0..float_max_split] +foreign import ccall "&hs_bytestring_float_pow5_split" + float_pow5_split :: Ptr Word64 +#endif + +-- | Number of mantissa bits of a 32-bit float. The number of significant bits +-- (floatDigits (undefined :: Float)) is 24 since we have a leading 1 for +-- normal floats and 0 for subnormal floats +float_mantissa_bits :: Int +float_mantissa_bits = 23 + +-- | Number of exponent bits of a 32-bit float +float_exponent_bits :: Int +float_exponent_bits = 8 + +-- | Bias in encoded 32-bit float representation (2^7 - 1) +float_bias :: Int +float_bias = 127 + +data FloatingDecimal = FloatingDecimal + { fmantissa :: !Word32 + , fexponent :: !Int32 + } deriving (Show, Eq) + +-- | Multiply a 32-bit number with a 64-bit number while keeping the upper 64 +-- bits. Then shift by specified amount minus 32 +mulShift32 :: Word32 -> Word64 -> Int -> Word32 +mulShift32 m factor shift = + let factorLo = factor .&. mask 32 + factorHi = factor `unsafeShiftR` 32 + bits0 = word32ToWord64 m * factorLo + bits1 = word32ToWord64 m * factorHi + total = (bits0 `unsafeShiftR` 32) + bits1 + in word64ToWord32 $ total `unsafeShiftR` (shift - 32) + +-- | Index into the 64-bit word lookup table float_pow5_inv_split +get_float_pow5_inv_split :: Int -> Word64 +#if !PURE_HASKELL +get_float_pow5_inv_split = getWord64At float_pow5_inv_split +#else +-- > putStr $ case64 (finv float_pow5_inv_bitcount) [0..float_max_inv_split] +get_float_pow5_inv_split i = case i of + 0 -> 0x800000000000001 + 1 -> 0x666666666666667 + 2 -> 0x51eb851eb851eb9 + 3 -> 0x4189374bc6a7efa + 4 -> 0x68db8bac710cb2a + 5 -> 0x53e2d6238da3c22 + 6 -> 0x431bde82d7b634e + 7 -> 0x6b5fca6af2bd216 + 8 -> 0x55e63b88c230e78 + 9 -> 0x44b82fa09b5a52d + 10 -> 0x6df37f675ef6eae + 11 -> 0x57f5ff85e592558 + 12 -> 0x465e6604b7a8447 + 13 -> 0x709709a125da071 + 14 -> 0x5a126e1a84ae6c1 + 15 -> 0x480ebe7b9d58567 + 16 -> 0x734aca5f6226f0b + 17 -> 0x5c3bd5191b525a3 + 18 -> 0x49c97747490eae9 + 19 -> 0x760f253edb4ab0e + 20 -> 0x5e72843249088d8 + 21 -> 0x4b8ed0283a6d3e0 + 22 -> 0x78e480405d7b966 + 23 -> 0x60b6cd004ac9452 + 24 -> 0x4d5f0a66a23a9db + 25 -> 0x7bcb43d769f762b + 26 -> 0x63090312bb2c4ef + 27 -> 0x4f3a68dbc8f03f3 + 28 -> 0x7ec3daf94180651 + 29 -> 0x65697bfa9acd1da + _ -> 0x51212ffbaf0a7e2 +#endif + +-- | Index into the 64-bit word lookup table float_pow5_split +get_float_pow5_split :: Int -> Word64 +#if !PURE_HASKELL +get_float_pow5_split = getWord64At float_pow5_split +#else +-- > putStr $ case64 (fnorm float_pow5_bitcount) [0..float_max_split] +get_float_pow5_split i = case i of + 0 -> 0x1000000000000000 + 1 -> 0x1400000000000000 + 2 -> 0x1900000000000000 + 3 -> 0x1f40000000000000 + 4 -> 0x1388000000000000 + 5 -> 0x186a000000000000 + 6 -> 0x1e84800000000000 + 7 -> 0x1312d00000000000 + 8 -> 0x17d7840000000000 + 9 -> 0x1dcd650000000000 + 10 -> 0x12a05f2000000000 + 11 -> 0x174876e800000000 + 12 -> 0x1d1a94a200000000 + 13 -> 0x12309ce540000000 + 14 -> 0x16bcc41e90000000 + 15 -> 0x1c6bf52634000000 + 16 -> 0x11c37937e0800000 + 17 -> 0x16345785d8a00000 + 18 -> 0x1bc16d674ec80000 + 19 -> 0x1158e460913d0000 + 20 -> 0x15af1d78b58c4000 + 21 -> 0x1b1ae4d6e2ef5000 + 22 -> 0x10f0cf064dd59200 + 23 -> 0x152d02c7e14af680 + 24 -> 0x1a784379d99db420 + 25 -> 0x108b2a2c28029094 + 26 -> 0x14adf4b7320334b9 + 27 -> 0x19d971e4fe8401e7 + 28 -> 0x1027e72f1f128130 + 29 -> 0x1431e0fae6d7217c + 30 -> 0x193e5939a08ce9db + 31 -> 0x1f8def8808b02452 + 32 -> 0x13b8b5b5056e16b3 + 33 -> 0x18a6e32246c99c60 + 34 -> 0x1ed09bead87c0378 + 35 -> 0x13426172c74d822b + 36 -> 0x1812f9cf7920e2b6 + 37 -> 0x1e17b84357691b64 + 38 -> 0x12ced32a16a1b11e + 39 -> 0x178287f49c4a1d66 + 40 -> 0x1d6329f1c35ca4bf + 41 -> 0x125dfa371a19e6f7 + 42 -> 0x16f578c4e0a060b5 + 43 -> 0x1cb2d6f618c878e3 + 44 -> 0x11efc659cf7d4b8d + 45 -> 0x166bb7f0435c9e71 + _ -> 0x1c06a5ec5433c60d +#endif + +-- | Take the high bits of m * 2^k / 5^q / 2^-e2+q+k +mulPow5InvDivPow2 :: Word32 -> Int -> Int -> Word32 +mulPow5InvDivPow2 m q j = mulShift32 m (get_float_pow5_inv_split q) j + +-- | Take the high bits of m * 5^-e2-q / 2^k / 2^q-k +mulPow5DivPow2 :: Word32 -> Int -> Int -> Word32 +mulPow5DivPow2 m i j = mulShift32 m (get_float_pow5_split i) j + +-- | Handle case e2 >= 0 +f2dGT :: Int32 -> Word32 -> Word32 -> Word32 -> (BoundsState Word32, Int32) +f2dGT e2' u v w = + let e2 = int32ToInt e2' + -- q = e10 = log_10(2^e2) + q = log10pow2 e2 + -- k = B0 + log_2(5^q) + k = float_pow5_inv_bitcount + pow5bits q - 1 + i = -e2 + q + k + -- (u, v, w) * 2^k / 5^q / 2^-e2+q+k + u' = mulPow5InvDivPow2 u q i + v' = mulPow5InvDivPow2 v q i + w' = mulPow5InvDivPow2 w q i + !lastRemoved = + if q /= 0 && fquot10 (w' - 1) <= fquot10 u' + -- We need to know one removed digit even if we are not going to loop + -- below. We could use q = X - 1 above, except that would require 33 + -- bits for the result, and we've found that 32-bit arithmetic is + -- faster even on 64-bit machines. + then let l = float_pow5_inv_bitcount + pow5bits (q - 1) - 1 + in frem10 (mulPow5InvDivPow2 v (q - 1) (-e2 + q - 1 + l)) + else 0 + !(vvTrailing, vuTrailing, vw') = + case () of + _ | q < 9 && frem5 v == 0 + -> (multipleOfPowerOf5 v q, False, w') + | q < 9 && acceptBounds v + -> (False, multipleOfPowerOf5 u q, w') + | q < 9 + -> (False, False, w' - boolToWord32 (multipleOfPowerOf5 w q)) + | otherwise + -> (False, False, w') + in (BoundsState u' v' vw' lastRemoved vuTrailing vvTrailing, intToInt32 q) + +-- | Handle case e2 < 0 +f2dLT :: Int32 -> Word32 -> Word32 -> Word32 -> (BoundsState Word32, Int32) +f2dLT e2' u v w = + let e2 = int32ToInt e2' + q = log10pow5 (-e2) + e10 = q + e2 + i = (-e2) - q + -- k = log_2(5^-e2-q) - B1 + k = pow5bits i - float_pow5_bitcount + j = q - k + -- (u, v, w) * 5^-e2-q / 2^k / 2^q-k + u' = mulPow5DivPow2 u i j + v' = mulPow5DivPow2 v i j + w' = mulPow5DivPow2 w i j + !lastRemoved = + if q /= 0 && fquot10 (w' - 1) <= fquot10 u' + then let j' = q - 1 - (pow5bits (i + 1) - float_pow5_bitcount) + in frem10 (mulPow5DivPow2 v (i + 1) j') + else 0 + !(vvTrailing , vuTrailing, vw') = + case () of + _ | q <= 1 && acceptBounds v + -> (True, v - u == 2, w') -- mmShift == 1 + | q <= 1 + -> (True, False, w' - 1) + | q < 31 + -> (multipleOfPowerOf2 v (q - 1), False, w') + | otherwise + -> (False, False, w') + in (BoundsState u' v' vw' lastRemoved vuTrailing vvTrailing, intToInt32 e10) + +-- | Returns the decimal representation of the given mantissa and exponent of a +-- 32-bit Float using the ryu algorithm. +f2d :: Word32 -> Word32 -> FloatingDecimal +f2d m e = + let !mf = if e == 0 + then m + else (1 `unsafeShiftL` float_mantissa_bits) .|. m + !ef = intToInt32 $ if e == 0 + then 1 - (float_bias + float_mantissa_bits) + else word32ToInt e - (float_bias + float_mantissa_bits) + !e2 = ef - 2 + -- Step 2. 3-tuple (u, v, w) * 2**e2 + !u = 4 * mf - 1 - boolToWord32 (m /= 0 || e <= 1) + !v = 4 * mf + !w = 4 * mf + 2 + -- Step 3. convert to decimal power base + !(state, e10) = + if e2 >= 0 + then f2dGT e2 u v w + else f2dLT e2 u v w + -- Step 4: Find the shortest decimal representation in the interval of + -- valid representations. + !(output, removed) = + let rounded = closestCorrectlyRounded (acceptBounds v) + in first rounded $ if vvIsTrailingZeros state || vuIsTrailingZeros state + then trimTrailing state + else trimNoTrailing state + !e' = e10 + removed + in FloatingDecimal output e' + +-- | Split a Float into (sign, mantissa, exponent) +breakdown :: Float -> (Bool, Word32, Word32) +breakdown f = + let bits = castFloatToWord32 f + sign = ((bits `unsafeShiftR` (float_mantissa_bits + float_exponent_bits)) .&. 1) /= 0 + mantissa = bits .&. mask float_mantissa_bits + expo = (bits `unsafeShiftR` float_mantissa_bits) .&. mask float_exponent_bits + in (sign, mantissa, expo) + +-- | Dispatches to `f2d` and applies the given formatters +{-# INLINE f2s' #-} +f2s' :: (Bool -> Word32 -> Int32 -> a) -> (NonNumbersAndZero -> a) -> Float -> a +f2s' formatter specialFormatter f = + let (sign, mantissa, expo) = breakdown f + in if (expo == mask float_exponent_bits) || (expo == 0 && mantissa == 0) + then specialFormatter NonNumbersAndZero + { negative=sign + , exponent_all_one=expo > 0 + , mantissa_non_zero=mantissa > 0 } + else let FloatingDecimal m e = f2d mantissa expo + in formatter sign m e + +-- | Render a Float in scientific notation +f2s :: Float -> Builder +f2s f = primBounded (f2s' toCharsScientific toCharsNonNumbersAndZero f) () + +-- | Returns the decimal representation of a Float. NaN and Infinity will +-- return `FloatingDecimal 0 0` +f2Intermediate :: Float -> FloatingDecimal +f2Intermediate = f2s' (const FloatingDecimal) (const $ FloatingDecimal 0 0) diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -0,0 +1,864 @@ +{-# LANGUAGE CPP #-} + +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Data.ByteString.Builder.RealFloat.Internal +-- Copyright : (c) Lawrence Wu 2021 +-- License : BSD-style +-- Maintainer : lawrencejwu@gmail.com +-- +-- Various floating-to-string conversion helpers that are somewhat +-- floating-size agnostic +-- +-- This module includes +-- +-- - Efficient formatting for scientific floating-to-string +-- - Trailing zero handling when converting to decimal power base +-- - Approximations for logarithms of powers +-- - Fast-division by reciprocal multiplication +-- - Prim-op bit-wise peek + +module Data.ByteString.Builder.RealFloat.Internal + ( mask + , NonNumbersAndZero(..) + , toCharsNonNumbersAndZero + , decimalLength9 + , decimalLength17 + , Mantissa + , pow5bits + , log10pow2 + , log10pow5 + , pow5_factor + , multipleOfPowerOf5 + , multipleOfPowerOf2 + , acceptBounds + , BoundsState(..) + , trimTrailing + , trimNoTrailing + , closestCorrectlyRounded + , toCharsScientific + -- hand-rolled division and remainder for f2s and d2s + , fquot10 + , frem10 + , fquot5 + , frem5 + , dquot10 + , dquotRem10 + , dquot5 + , drem5 + , dquot100 + -- prim-op helpers + , timesWord2 + , castDoubleToWord64 + , castFloatToWord32 + , getWord64At + , getWord128At + -- monomorphic conversions + , boolToWord32 + , boolToWord64 + , int32ToInt + , intToInt32 + , word32ToInt + , word64ToInt + , word32ToWord64 + , word64ToWord32 + + , module Data.ByteString.Builder.RealFloat.TableGenerator + ) where + +import Control.Monad (foldM) +import Data.Bits (Bits(..), FiniteBits(..)) +import Data.ByteString.Internal (c2w) +import Data.ByteString.Builder.Prim.Internal (BoundedPrim, boundedPrim) +import Data.ByteString.Builder.RealFloat.TableGenerator +import Data.ByteString.Utils.ByteOrder +import Data.ByteString.Utils.UnalignedAccess +#if PURE_HASKELL +import qualified Data.ByteString.Internal.Pure as Pure +#else +import Foreign.C.Types +#endif +import Data.Char (ord) +import GHC.Int (Int(..), Int32(..)) +import GHC.IO (IO(..), unIO) +import GHC.Prim +import GHC.Ptr (Ptr(..), plusPtr, castPtr) +import GHC.Types (isTrue#) +import GHC.Word (Word8, Word16(..), Word32(..), Word64(..)) +import qualified Foreign.Storable as S (poke) + +#include +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS < 64 && !MIN_VERSION_ghc_prim(0,8,0) +import GHC.IntWord64 +#endif + +import Data.ByteString.Builder.Prim.Internal.Floating + (castFloatToWord32, castDoubleToWord64) + +-- | Build a full bit-mask of specified length. +-- +-- e.g +-- +-- > showHex (mask 12) [] = "fff" +{-# INLINABLE mask #-} +mask :: (Bits a, Integral a) => Int -> a +mask = flip (-) 1 . unsafeShiftL 1 + +-- | Convert boolean false to 0 and true to 1 +{-# INLINABLE boolToWord32 #-} +boolToWord32 :: Bool -> Word32 +boolToWord32 = fromIntegral . fromEnum + +-- | Convert boolean false to 0 and true to 1 +{-# INLINABLE boolToWord64 #-} +boolToWord64 :: Bool -> Word64 +boolToWord64 = fromIntegral . fromEnum + +-- | Monomorphic conversion for @Int32 -> Int@ +{-# INLINABLE int32ToInt #-} +int32ToInt :: Int32 -> Int +int32ToInt = fromIntegral + +-- | Monomorphic conversion for @Int -> Int32@ +{-# INLINABLE intToInt32 #-} +intToInt32 :: Int -> Int32 +intToInt32 = fromIntegral + +-- | Monomorphic conversion for @Word32 -> Int@ +{-# INLINABLE word32ToInt #-} +word32ToInt :: Word32 -> Int +word32ToInt = fromIntegral + +-- | Monomorphic conversion for @Word64 -> Int@ +{-# INLINABLE word64ToInt #-} +word64ToInt :: Word64 -> Int +word64ToInt = fromIntegral + +-- | Monomorphic conversion for @Word32 -> Word64@ +{-# INLINABLE word32ToWord64 #-} +word32ToWord64 :: Word32 -> Word64 +word32ToWord64 = fromIntegral + +-- | Monomorphic conversion for @Word64 -> Word32@ +{-# INLINABLE word64ToWord32 #-} +word64ToWord32 :: Word64 -> Word32 +word64ToWord32 = fromIntegral + + +-- | Returns the number of decimal digits in v, which must not contain more than 9 digits. +decimalLength9 :: Word32 -> Int +decimalLength9 v + | v >= 100000000 = 9 + | v >= 10000000 = 8 + | v >= 1000000 = 7 + | v >= 100000 = 6 + | v >= 10000 = 5 + | v >= 1000 = 4 + | v >= 100 = 3 + | v >= 10 = 2 + | otherwise = 1 + +-- | Returns the number of decimal digits in v, which must not contain more than 17 digits. +decimalLength17 :: Word64 -> Int +decimalLength17 v + | v >= 10000000000000000 = 17 + | v >= 1000000000000000 = 16 + | v >= 100000000000000 = 15 + | v >= 10000000000000 = 14 + | v >= 1000000000000 = 13 + | v >= 100000000000 = 12 + | v >= 10000000000 = 11 + | v >= 1000000000 = 10 + | v >= 100000000 = 9 + | v >= 10000000 = 8 + | v >= 1000000 = 7 + | v >= 100000 = 6 + | v >= 10000 = 5 + | v >= 1000 = 4 + | v >= 100 = 3 + | v >= 10 = 2 + | otherwise = 1 + +-- From 'In-and-Out Conversions' https://dl.acm.org/citation.cfm?id=362887, we +-- have that a conversion from a base-b n-digit number to a base-v m-digit +-- number such that the round-trip conversion is identity requires +-- +-- v^(m-1) > b^n +-- +-- Specifically for binary floating point to decimal conversion, we must have +-- +-- 10^(m-1) > 2^n +-- => log(10^(m-1)) > log(2^n) +-- => (m-1) * log(10) > n * log(2) +-- => m-1 > n * log(2) / log(10) +-- => m-1 >= ceil(n * log(2) / log(10)) +-- => m >= ceil(n * log(2) / log(10)) + 1 +-- +-- And since 32 and 64-bit floats have 23 and 52 bits of mantissa (and then an +-- implicit leading-bit), we need +-- +-- ceil(24 * log(2) / log(10)) + 1 => 9 +-- ceil(53 * log(2) / log(10)) + 1 => 17 +-- +-- In addition, the exponent range from floats is [-45,38] and doubles is +-- [-324,308] (including subnormals) which are 3 and 4 digits respectively +-- +-- Thus we have, +-- +-- floats: 1 (sign) + 9 (mantissa) + 1 (.) + 1 (e) + 3 (exponent) = 15 +-- doubles: 1 (sign) + 17 (mantissa) + 1 (.) + 1 (e) + 4 (exponent) = 24 +-- +maxEncodedLength :: Int +maxEncodedLength = 32 + +-- | Storable.poke a String into a Ptr Word8, converting through c2w +pokeAll :: String -> Ptr Word8 -> IO (Ptr Word8) +pokeAll s ptr = foldM pokeOne ptr s + where pokeOne p c = S.poke p (c2w c) >> return (p `plusPtr` 1) + +-- | Unsafe creation of a bounded primitive of String at most length +-- `maxEncodedLength` +boundString :: String -> BoundedPrim () +boundString s = boundedPrim maxEncodedLength $ const (pokeAll s) + +-- | Special rendering for NaN, positive\/negative 0, and positive\/negative +-- infinity. These are based on the IEEE representation of non-numbers. +-- +-- Infinity +-- +-- * sign = 0 for positive infinity, 1 for negative infinity. +-- * biased exponent = all 1 bits. +-- * fraction = all 0 bits. +-- +-- NaN +-- +-- * sign = either 0 or 1 (ignored) +-- * biased exponent = all 1 bits. +-- * fraction = anything except all 0 bits. +-- +-- We also handle 0 specially here so that the exponent rendering is more +-- correct. +-- +-- * sign = either 0 or 1. +-- * biased exponent = all 0 bits. +-- * fraction = all 0 bits. +data NonNumbersAndZero = NonNumbersAndZero + { negative :: Bool + , exponent_all_one :: Bool + , mantissa_non_zero :: Bool + } + +-- | Renders NonNumbersAndZero into bounded primitive +toCharsNonNumbersAndZero :: NonNumbersAndZero -> BoundedPrim () +toCharsNonNumbersAndZero NonNumbersAndZero{..} + | mantissa_non_zero = boundString "NaN" + | exponent_all_one = boundString $ signStr ++ "Infinity" + | otherwise = boundString $ signStr ++ "0.0e0" + where signStr = if negative then "-" else "" + +-- | Part of the calculation on whether to round up the decimal representation. +-- This is currently a constant function to match behavior in Base `show` and +-- is implemented as +-- +-- @ +-- acceptBounds _ = False +-- @ +-- +-- For round-to-even and correct shortest, use +-- +-- @ +-- acceptBounds v = ((v \`quot\` 4) .&. 1) == 0 +-- @ +acceptBounds :: Mantissa a => a -> Bool +acceptBounds _ = False + +------------------------------------------------------------------------------- +-- Logarithm Approximations +-- +-- These are based on the same transformations. +-- +-- e.g +-- +-- log_2(5^e) goal function +-- = e * log_2(5) log exponenation +-- ~= e * floor(10^7 * log_2(5)) / 10^7 integer operations +-- ~= e * 1217359 / 2^19 approximation into n / 2^m +-- +-- These are verified in the unit tests for the given input ranges +------------------------------------------------------------------------------- + +-- | Returns e == 0 ? 1 : ceil(log_2(5^e)); requires 0 <= e <= 3528. +pow5bitsUnboxed :: Int# -> Int# +pow5bitsUnboxed e = (e *# 1217359#) `uncheckedIShiftRL#` 19# +# 1# + +-- | Returns floor(log_10(2^e)); requires 0 <= e <= 1650. +log10pow2Unboxed :: Int# -> Int# +log10pow2Unboxed e = (e *# 78913#) `uncheckedIShiftRL#` 18# + +-- | Returns floor(log_10(5^e)); requires 0 <= e <= 2620. +log10pow5Unboxed :: Int# -> Int# +log10pow5Unboxed e = (e *# 732923#) `uncheckedIShiftRL#` 20# + +-- | Boxed versions of the functions above +pow5bits, log10pow2, log10pow5 :: Int -> Int +pow5bits = wrapped pow5bitsUnboxed +log10pow2 = wrapped log10pow2Unboxed +log10pow5 = wrapped log10pow5Unboxed + +------------------------------------------------------------------------------- +-- Fast Division +-- +-- Division is slow. We leverage fixed-point arithmetic to calculate division +-- by a constant as multiplication by the inverse. This could potentially be +-- handled by an aggressive compiler, but to ensure that the optimization +-- happens, we hard-code the expected divisions / remainders by 5, 10, 100, etc +-- +-- e.g +-- +-- x / 5 goal function +-- = x * (1 / 5) reciprocal +-- = x * (4 / 5) / 4 +-- = x * 0b0.110011001100.. / 4 recurring binary representation +-- ~= x * (0xCCCCCCCD / 2^32) / 4 approximation with integers +-- = (x * 0xCCCCCCCD) >> 34 +-- +-- Look for `Reciprocal Multiplication, a tutorial` by Douglas W. Jones for a +-- more detailed explanation. +------------------------------------------------------------------------------- + +-- | Returns @w / 10@ +fquot10 :: Word32 -> Word32 +fquot10 w = word64ToWord32 ((word32ToWord64 w * 0xCCCCCCCD) `unsafeShiftR` 35) + +-- | Returns @w % 10@ +frem10 :: Word32 -> Word32 +frem10 w = w - fquot10 w * 10 + +-- | Returns @(w / 10, w % 10)@ +fquotRem10 :: Word32 -> (Word32, Word32) +fquotRem10 w = + let w' = fquot10 w + in (w', w - fquot10 w * 10) + +-- | Returns @w / 100@ +fquot100 :: Word32 -> Word32 +fquot100 w = word64ToWord32 ((word32ToWord64 w * 0x51EB851F) `unsafeShiftR` 37) + +-- | Returns @(w / 10000, w % 10000)@ +fquotRem10000 :: Word32 -> (Word32, Word32) +fquotRem10000 w = + let w' = word64ToWord32 ((word32ToWord64 w * 0xD1B71759) `unsafeShiftR` 45) + in (w', w - w' * 10000) + +-- | Returns @w / 5@ +fquot5 :: Word32 -> Word32 +fquot5 w = word64ToWord32 ((word32ToWord64 w * 0xCCCCCCCD) `unsafeShiftR` 34) + +-- | Returns @w % 5@ +frem5 :: Word32 -> Word32 +frem5 w = w - fquot5 w * 5 + +-- | Returns @w / 10@ +dquot10 :: Word64 -> Word64 +dquot10 w = + let !(rdx, _) = w `timesWord2` 0xCCCCCCCCCCCCCCCD + in rdx `unsafeShiftR` 3 + +-- | Returns @w / 100@ +dquot100 :: Word64 -> Word64 +dquot100 w = + let !(rdx, _) = (w `unsafeShiftR` 2) `timesWord2` 0x28F5C28F5C28F5C3 + in rdx `unsafeShiftR` 2 + +-- | Returns @(w / 10000, w % 10000)@ +dquotRem10000 :: Word64 -> (Word64, Word64) +dquotRem10000 w = + let !(rdx, _) = w `timesWord2` 0x346DC5D63886594B + w' = rdx `unsafeShiftR` 11 + in (w', w - w' * 10000) + +-- | Returns @(w / 10, w % 10)@ +dquotRem10 :: Word64 -> (Word64, Word64) +dquotRem10 w = + let w' = dquot10 w + in (w', w - w' * 10) + +-- | Returns @w / 5@ +dquot5 :: Word64 -> Word64 +dquot5 w = + let !(rdx, _) = w `timesWord2` 0xCCCCCCCCCCCCCCCD + in rdx `unsafeShiftR` 2 + +-- | Returns @w % 5@ +drem5 :: Word64 -> Word64 +drem5 w = w - dquot5 w * 5 + +-- | Returns @(w / 5, w % 5)@ +dquotRem5 :: Word64 -> (Word64, Word64) +dquotRem5 w = + let w' = dquot5 w + in (w', w - w' * 5) + +-- | Wrap a unboxed function on Int# into the boxed equivalent +wrapped :: (Int# -> Int#) -> Int -> Int +wrapped f (I# w) = I# (f w) + +#if WORD_SIZE_IN_BITS == 32 +-- | Packs 2 32-bit system words (hi, lo) into a Word64 +packWord64 :: Word# -> Word# -> Word64# +packWord64 hi lo = case hostByteOrder of + BigEndian -> + ((wordToWord64# lo) `uncheckedShiftL64#` 32#) `or64#` (wordToWord64# hi) + LittleEndian -> + ((wordToWord64# hi) `uncheckedShiftL64#` 32#) `or64#` (wordToWord64# lo) + +-- | Unpacks a Word64 into 2 32-bit words (hi, lo) +unpackWord64 :: Word64# -> (# Word#, Word# #) +unpackWord64 w = case hostByteOrder of + BigEndian -> + (# word64ToWord# w + , word64ToWord# (w `uncheckedShiftRL64#` 32#) + #) + LittleEndian -> + (# word64ToWord# (w `uncheckedShiftRL64#` 32#) + , word64ToWord# w + #) + +-- | Adds 2 Word64's with 32-bit addition and manual carrying +plusWord64 :: Word64# -> Word64# -> Word64# +plusWord64 x y = + let !(# x_h, x_l #) = unpackWord64 x + !(# y_h, y_l #) = unpackWord64 y + lo = x_l `plusWord#` y_l + carry = int2Word# (lo `ltWord#` x_l) + hi = x_h `plusWord#` y_h `plusWord#` carry + in packWord64 hi lo +#endif + +-- | Boxed version of `timesWord2#` for 64 bits +timesWord2 :: Word64 -> Word64 -> (Word64, Word64) +timesWord2 a b = + let ra = raw a + rb = raw b +#if WORD_SIZE_IN_BITS >= 64 +#if __GLASGOW_HASKELL__ < 903 + !(# hi, lo #) = ra `timesWord2#` rb +#else + !(# hi_, lo_ #) = word64ToWord# ra `timesWord2#` word64ToWord# rb + hi = wordToWord64# hi_ + lo = wordToWord64# lo_ +#endif +#else + !(# x_h, x_l #) = unpackWord64 ra + !(# y_h, y_l #) = unpackWord64 rb + + !(# phh_h, phh_l #) = x_h `timesWord2#` y_h + !(# phl_h, phl_l #) = x_h `timesWord2#` y_l + !(# plh_h, plh_l #) = x_l `timesWord2#` y_h + !(# pll_h, pll_l #) = x_l `timesWord2#` y_l + + -- x1 x0 + -- X y1 y0 + -- ------------- + -- 00 LOW PART + -- ------------- + -- 00 + -- 10 10 MIDDLE PART + -- + 01 + -- ------------- + -- 01 + -- + 11 11 HIGH PART + -- ------------- + + phh = packWord64 phh_h phh_l + phl = packWord64 phl_h phl_l + + !(# mh, ml #) = unpackWord64 (phl + `plusWord64` (wordToWord64# pll_h) + `plusWord64` (wordToWord64# plh_l)) + + hi = phh + `plusWord64` (wordToWord64# mh) + `plusWord64` (wordToWord64# plh_h) + + lo = packWord64 ml pll_l +#endif + in (W64# hi, W64# lo) + +-- | #ifdef for 64-bit word that seems to work on both 32- and 64-bit platforms +type WORD64 = +#if WORD_SIZE_IN_BITS < 64 || __GLASGOW_HASKELL__ >= 903 + Word64# +#else + Word# +#endif + +-- | Returns the number of times @w@ is divisible by @5@ +pow5_factor :: WORD64 -> Int# -> Int# +pow5_factor w count = + let !(W64# q, W64# r) = dquotRem5 (W64# w) +#if WORD_SIZE_IN_BITS >= 64 && __GLASGOW_HASKELL__ < 903 + in case r `eqWord#` 0## of +#else + in case r `eqWord64#` wordToWord64# 0## of +#endif + 0# -> count + _ -> pow5_factor q (count +# 1#) + +-- | Returns @True@ if value is divisible by @5^p@ +multipleOfPowerOf5 :: Mantissa a => a -> Int -> Bool +multipleOfPowerOf5 value (I# p) = isTrue# (pow5_factor (raw value) 0# >=# p) + +-- | Returns @True@ if value is divisible by @2^p@ +multipleOfPowerOf2 :: Mantissa a => a -> Int -> Bool +multipleOfPowerOf2 value p = (value .&. mask p) == 0 + +-- | Wrapper for polymorphic handling of 32- and 64-bit floats +class (FiniteBits a, Integral a) => Mantissa a where + -- NB: might truncate! + -- Use this when we know the value fits in 32-bits + unsafeRaw :: a -> Word# + raw :: a -> WORD64 + + decimalLength :: a -> Int + boolToWord :: Bool -> a + quotRem10 :: a -> (a, a) + quot10 :: a -> a + quot100 :: a -> a + quotRem100 :: a -> (a, a) + quotRem10000 :: a -> (a, a) + +instance Mantissa Word32 where +#if __GLASGOW_HASKELL__ >= 902 + unsafeRaw (W32# w) = word32ToWord# w +#else + unsafeRaw (W32# w) = w +#endif +#if WORD_SIZE_IN_BITS >= 64 && __GLASGOW_HASKELL__ < 903 + raw = unsafeRaw +#else + raw w = wordToWord64# (unsafeRaw w) +#endif + + decimalLength = decimalLength9 + boolToWord = boolToWord32 + + {-# INLINE quotRem10 #-} + quotRem10 = fquotRem10 + + {-# INLINE quot10 #-} + quot10 = fquot10 + + {-# INLINE quot100 #-} + quot100 = fquot100 + + quotRem100 w = + let w' = fquot100 w + in (w', (w - w' * 100)) + + quotRem10000 = fquotRem10000 + +instance Mantissa Word64 where +#if WORD_SIZE_IN_BITS >= 64 && __GLASGOW_HASKELL__ < 903 + unsafeRaw (W64# w) = w +#else + unsafeRaw (W64# w) = word64ToWord# w +#endif + raw (W64# w) = w + + decimalLength = decimalLength17 + boolToWord = boolToWord64 + + {-# INLINE quotRem10 #-} + quotRem10 = dquotRem10 + + {-# INLINE quot10 #-} + quot10 = dquot10 + + {-# INLINE quot100 #-} + quot100 = dquot100 + + quotRem100 w = + let w' = dquot100 w + in (w', (w - w' * 100)) + + quotRem10000 = dquotRem10000 + +-- | Bookkeeping state for finding the shortest, correctly-rounded +-- representation. The same trimming algorithm is similar enough for 32- and +-- 64-bit floats +data BoundsState a = BoundsState + { vu :: !a + , vv :: !a + , vw :: !a + , lastRemovedDigit :: !a + , vuIsTrailingZeros :: !Bool + , vvIsTrailingZeros :: !Bool + } + +-- | Trim digits and update bookkeeping state when the table-computed +-- step results in trailing zeros (the general case, happens rarely) +-- +-- NB: This function isn't actually necessary so long as acceptBounds is always +-- @False@ since we don't do anything different with the trailing-zero +-- information directly: +-- - vuIsTrailingZeros is always False. We can see this by noting that in all +-- places where vuTrailing can possible be True, we must have acceptBounds be +-- True (accept_smaller) +-- - The final result doesn't change the lastRemovedDigit for rounding anyway +trimTrailing :: (Show a, Mantissa a) => BoundsState a -> (BoundsState a, Int32) +trimTrailing !initial = (res, r + r') + where + !(d', r) = trimTrailing' initial + !(d'', r') = if vuIsTrailingZeros d' then trimTrailing'' d' else (d', 0) + res = if vvIsTrailingZeros d'' && lastRemovedDigit d'' == 5 && vv d'' `rem` 2 == 0 + -- set `{ lastRemovedDigit = 4 }` to round-even + then d'' + else d'' + + trimTrailing' !d + | vw' > vu' = + fmap ((+) 1) . trimTrailing' $ + d { vu = vu' + , vv = vv' + , vw = vw' + , lastRemovedDigit = vvRem + , vuIsTrailingZeros = vuIsTrailingZeros d && vuRem == 0 + , vvIsTrailingZeros = vvIsTrailingZeros d && lastRemovedDigit d == 0 + } + | otherwise = (d, 0) + where + !(vv', vvRem) = quotRem10 $ vv d + !(vu', vuRem) = quotRem10 $ vu d + !(vw', _ ) = quotRem10 $ vw d + + trimTrailing'' !d + | vuRem == 0 = + fmap ((+) 1) . trimTrailing'' $ + d { vu = vu' + , vv = vv' + , vw = vw' + , lastRemovedDigit = vvRem + , vvIsTrailingZeros = vvIsTrailingZeros d && lastRemovedDigit d == 0 + } + | otherwise = (d, 0) + where + !(vu', vuRem) = quotRem10 $ vu d + !(vv', vvRem) = quotRem10 $ vv d + !(vw', _ ) = quotRem10 $ vw d + + +-- | Trim digits and update bookkeeping state when the table-computed +-- step results has no trailing zeros (common case) +trimNoTrailing :: Mantissa a => BoundsState a -> (BoundsState a, Int32) +trimNoTrailing !(BoundsState u v w ld _ _) = + (BoundsState ru' rv' 0 ld' False False, c) + where + !(ru', rv', ld', c) = trimNoTrailing' u v w ld 0 + + trimNoTrailing' u' v' w' lastRemoved count + -- Loop iterations below (approximately), without div 100 optimization: + -- 0: 0.03%, 1: 13.8%, 2: 70.6%, 3: 14.0%, 4: 1.40%, 5: 0.14%, 6+: 0.02% + -- Loop iterations below (approximately), with div 100 optimization: + -- 0: 70.6%, 1: 27.8%, 2: 1.40%, 3: 0.14%, 4+: 0.02% + | vw' > vu' = + trimNoTrailing'' vu' vv' vw' (quot10 (v' - (vv' * 100))) (count + 2) + | otherwise = + trimNoTrailing'' u' v' w' lastRemoved count + where + !vw' = quot100 w' + !vu' = quot100 u' + !vv' = quot100 v' + + trimNoTrailing'' u' v' w' lastRemoved count + | vw' > vu' = trimNoTrailing' vu' vv' vw' lastRemoved' (count + 1) + | otherwise = (u', v', lastRemoved, count) + where + !(vv', lastRemoved') = quotRem10 v' + !vu' = quot10 u' + !vw' = quot10 w' + +-- | Returns the correctly rounded decimal representation mantissa based on if +-- we need to round up (next decimal place >= 5) or if we are outside the +-- bounds +{-# INLINE closestCorrectlyRounded #-} +closestCorrectlyRounded :: Mantissa a => Bool -> BoundsState a -> a +closestCorrectlyRounded acceptBound s = vv s + boolToWord roundUp + where + outsideBounds = not (vuIsTrailingZeros s) || not acceptBound + roundUp = (vv s == vu s && outsideBounds) || lastRemovedDigit s >= 5 + +-- Wrappe around int2Word# +asciiRaw :: Int -> Word# +asciiRaw (I# i) = int2Word# i + +asciiZero :: Int +asciiZero = ord '0' + +asciiDot :: Int +asciiDot = ord '.' + +asciiMinus :: Int +asciiMinus = ord '-' + +ascii_e :: Int +ascii_e = ord 'e' + +-- | Convert a single-digit number to the ascii ordinal e.g '1' -> 0x31 +toAscii :: Word# -> Word# +toAscii a = a `plusWord#` asciiRaw asciiZero + +-- | Index into the 64-bit word lookup table provided +{-# INLINE getWord64At #-} +getWord64At :: Ptr Word64 -> Int -> Word64 +getWord64At (Ptr arr) (I# i) = W64# (indexWord64OffAddr# arr i) + +-- | Index into the 128-bit word lookup table provided +-- Return (# high-64-bits , low-64-bits #) +-- +-- NB: The lookup tables we use store the low 64 bits in +-- host-byte-order then the high 64 bits in host-byte-order +{-# INLINE getWord128At #-} +getWord128At :: Ptr Word64 -> Int -> (Word64, Word64) +getWord128At (Ptr arr) (I# i) = let + !hi = W64# (indexWord64OffAddr# arr (i *# 2# +# 1#)) + !lo = W64# (indexWord64OffAddr# arr (i *# 2#)) + in (hi, lo) + +-- | Packs 2 bytes [lsb, msb] into 16-bit word +packWord16 :: Word# -> Word# -> Word# +packWord16 l h = case hostByteOrder of + BigEndian -> + (h `uncheckedShiftL#` 8#) `or#` l + LittleEndian -> + (l `uncheckedShiftL#` 8#) `or#` h + +-- | Unpacks a 16-bit word into 2 bytes [lsb, msb] +unpackWord16 :: Word# -> (# Word#, Word# #) +unpackWord16 w = case hostByteOrder of + BigEndian -> + (# w `and#` 0xff##, w `uncheckedShiftRL#` 8# #) + LittleEndian -> + (# w `uncheckedShiftRL#` 8#, w `and#` 0xff## #) + + +-- | Static array of 2-digit pairs 00..99 for faster ascii rendering +digit_table :: Ptr Word16 +digit_table = +#if PURE_HASKELL + castPtr Pure.digit_pairs_table +#else + castPtr c_digit_pairs_table + +foreign import ccall "&hs_bytestring_digit_pairs_table" + c_digit_pairs_table :: Ptr CChar +#endif + +-- | Unsafe index a static array for the 16-bit word at the index +unsafeAt :: Ptr Word16 -> Int# -> Word# +unsafeAt (Ptr a) i = +#if __GLASGOW_HASKELL__ >= 902 + word16ToWord# (indexWord16OffAddr# a i) +#else + indexWord16OffAddr# a i +#endif + +-- | Write a 16-bit word into the given address +copyWord16 :: Word# -> Addr# -> State# RealWorld -> State# RealWorld +copyWord16 w a s = let +#if __GLASGOW_HASKELL__ >= 902 + w16 = wordToWord16# w +#else + w16 = w +#endif + in case unIO (unalignedWriteU16 (W16# w16) (Ptr a)) s of + (# s', _ #) -> s' + +-- | Write an 8-bit word into the given address +poke :: Addr# -> Word# -> State# d -> State# d +poke a w s = +#if __GLASGOW_HASKELL__ >= 902 + writeWord8OffAddr# a 0# (wordToWord8# w) s +#else + writeWord8OffAddr# a 0# w s +#endif + +-- | Write the mantissa into the given address. This function attempts to +-- optimize this by writing pairs of digits simultaneously when the mantissa is +-- large enough +{-# SPECIALIZE writeMantissa :: Addr# -> Int# -> Word32 -> State# RealWorld -> (# Addr#, State# RealWorld #) #-} +{-# SPECIALIZE writeMantissa :: Addr# -> Int# -> Word64 -> State# RealWorld -> (# Addr#, State# RealWorld #) #-} +writeMantissa :: forall a. (Mantissa a) => Addr# -> Int# -> a -> State# RealWorld -> (# Addr#, State# RealWorld #) +writeMantissa ptr olength = go (ptr `plusAddr#` olength) + where + go p mantissa s1 + | mantissa >= 10000 = + let !(m', c) = quotRem10000 mantissa + !(c1, c0) = quotRem100 c + s2 = copyWord16 (digit_table `unsafeAt` word2Int# (unsafeRaw c0)) (p `plusAddr#` (-1#)) s1 + s3 = copyWord16 (digit_table `unsafeAt` word2Int# (unsafeRaw c1)) (p `plusAddr#` (-3#)) s2 + in go (p `plusAddr#` (-4#)) m' s3 + | mantissa >= 100 = + let !(m', c) = quotRem100 mantissa + s2 = copyWord16 (digit_table `unsafeAt` word2Int# (unsafeRaw c)) (p `plusAddr#` (-1#)) s1 + in finalize m' s2 + | otherwise = finalize mantissa s1 + finalize mantissa s1 + | mantissa >= 10 = + let !bs = digit_table `unsafeAt` word2Int# (unsafeRaw mantissa) + !(# lsb, msb #) = unpackWord16 bs + s2 = poke (ptr `plusAddr#` 2#) lsb s1 + s3 = poke (ptr `plusAddr#` 1#) (asciiRaw asciiDot) s2 + s4 = poke ptr msb s3 + in (# ptr `plusAddr#` (olength +# 1#), s4 #) + | (I# olength) > 1 = + let s2 = copyWord16 (packWord16 (asciiRaw asciiDot) (toAscii (unsafeRaw mantissa))) ptr s1 + in (# ptr `plusAddr#` (olength +# 1#), s2 #) + | otherwise = + let s2 = poke (ptr `plusAddr#` 2#) (asciiRaw asciiZero) s1 + s3 = poke (ptr `plusAddr#` 1#) (asciiRaw asciiDot) s2 + s4 = poke ptr (toAscii (unsafeRaw mantissa)) s3 + in (# ptr `plusAddr#` 3#, s4 #) + +-- | Write the exponent into the given address. +writeExponent :: Addr# -> Int32 -> State# RealWorld -> (# Addr#, State# RealWorld #) +writeExponent ptr !expo s1 + | expo >= 100 = + let !(e1, e0) = fquotRem10 (fromIntegral expo) -- TODO + s2 = copyWord16 (digit_table `unsafeAt` word2Int# (unsafeRaw e1)) ptr s1 + s3 = poke (ptr `plusAddr#` 2#) (toAscii (unsafeRaw e0)) s2 + in (# ptr `plusAddr#` 3#, s3 #) + | expo >= 10 = + let s2 = copyWord16 (digit_table `unsafeAt` e) ptr s1 + in (# ptr `plusAddr#` 2#, s2 #) + | otherwise = + let s2 = poke ptr (toAscii (int2Word# e)) s1 + in (# ptr `plusAddr#` 1#, s2 #) + where !(I# e) = int32ToInt expo + +-- | Write the sign into the given address. +writeSign :: Addr# -> Bool -> State# d -> (# Addr#, State# d #) +writeSign ptr True s1 = + let s2 = poke ptr (asciiRaw asciiMinus) s1 + in (# ptr `plusAddr#` 1#, s2 #) +writeSign ptr False s = (# ptr, s #) + +-- | Returns the decimal representation of a floating point number in +-- scientific (exponential) notation +{-# INLINABLE toCharsScientific #-} +{-# SPECIALIZE toCharsScientific :: Bool -> Word32 -> Int32 -> BoundedPrim () #-} +{-# SPECIALIZE toCharsScientific :: Bool -> Word64 -> Int32 -> BoundedPrim () #-} +toCharsScientific :: (Mantissa a) => Bool -> a -> Int32 -> BoundedPrim () +toCharsScientific !sign !mantissa !expo = boundedPrim maxEncodedLength $ \_ !(Ptr p0)-> do + let !olength@(I# ol) = decimalLength mantissa + !expo' = expo + intToInt32 olength - 1 + IO $ \s1 -> + let !(# p1, s2 #) = writeSign p0 sign s1 + !(# p2, s3 #) = writeMantissa p1 ol mantissa s2 + s4 = poke p2 (asciiRaw ascii_e) s3 + !(# p3, s5 #) = writeSign (p2 `plusAddr#` 1#) (expo' < 0) s4 + !(# p4, s6 #) = writeExponent p3 (abs expo') s5 + in (# s6, (Ptr p4) #) diff --git a/Data/ByteString/Builder/RealFloat/TableGenerator.hs b/Data/ByteString/Builder/RealFloat/TableGenerator.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/RealFloat/TableGenerator.hs @@ -0,0 +1,203 @@ +-- | +-- Module : Data.ByteString.Builder.RealFloat.TableGenerator +-- Copyright : (c) Lawrence Wu 2021 +-- License : BSD-style +-- Maintainer : lawrencejwu@gmail.com +-- +-- Constants and overview for compile-time table generation for Ryu internals +-- +-- This module uses Haskell's arbitrary-precision `Integer` types to compute +-- the necessary multipliers for efficient conversion to a decimal power base. +-- +-- It also exposes constants relevant to the 32- and 64-bit tables (e.g maximum +-- number of bits required to store the table values). + +module Data.ByteString.Builder.RealFloat.TableGenerator + ( float_pow5_inv_bitcount + , float_pow5_bitcount + , double_pow5_bitcount + , double_pow5_inv_bitcount + , float_max_split + , float_max_inv_split + , double_max_split + , double_max_inv_split + + , finv + , fnorm + , splitWord128s + , case64 + , case128 + ) where + +import GHC.Float (int2Double) + +import Data.Bits +import Data.Word +import Numeric + + +-- The basic floating point conversion algorithm is as such: +-- +-- Given floating point +-- +-- f = (-1)^s * m_f * 2^e_f +-- +-- which is IEEE encoded by `[s] [.. e ..] [.. m ..]`. `s` is the sign bit, `e` +-- is the biased exponent, and `m` is the mantissa, let +-- +-- | e /= 0 | e == 0 +-- -----+-------------------+----------- +-- m_f | 2^len(m) + m | m +-- e_f | e - bias - len(m) | 1 - bias - len(m) +-- +-- we compute the halfway points to the next smaller (`f-`) and larger (`f+`) +-- floating point numbers as +-- +-- lower halfway point u * 2^e2, u = 4 * m_f - (if m == 0 then 1 else 2) +-- v * 2^e2, v = 4 * m_f +-- upper halfway point w * 2^e2, u = 4 * m_f + 2 +-- where e2 = ef - 2 (so u, v, w are integers) +-- +-- +-- Then we compute (a, b, c) * 10^e10 = (u, v, w) * 2^e2 which is split into +-- the case of +-- +-- e2 >= 0 ==> e10 = 0 , (a, b, c) = (u, v, w) * 2^e2 +-- e2 < 0 ==> e10 = e2, (a, b, c) = (u, v, w) * 5^-e2 +-- +-- And finally we find the shortest representation from integers d0 and e0 such +-- that +-- +-- a * 10^e10 < d0 * 10^(e0+e10) < c * 10^e10 +-- +-- such that e0 is maximal (we allow equality to smaller or larger halfway +-- point depending on rounding mode). This is found through iteratively +-- dividing by 10 while a/10^j < c/10^j and doing some bookkeeping around +-- zeros. +-- +-- +-- +-- +-- The ryu algorithm removes the requirement for arbitrary precision arithmetic +-- and improves the runtime significantly by skipping most of the iterative +-- division by carefully selecting a point where certain invariants hold and +-- precomputing a few tables. +-- +-- Specifically, define `q` such that the correspondings values of a/10^q < +-- c/10^q - 1. We can prove (not shown) that +-- +-- if e2 >= 0, q = e2 * log_10(2) +-- if e2 < 0, q = -e2 * log_10(5) +-- +-- Then we can compute (a, b, c) / 10^q. Starting from (u, v, w) we have +-- +-- (a, b, c) / 10^q (a, b, c) / 10^q +-- = (u, v, w) * 2^e2 / 10^q OR = (u, v, w) * 5^-e2 / 10^q +-- +-- And since q < e2, +-- +-- = (u, v, w) * 2^e2-q / 5^q OR = (u, v, w) * 5^-e2-q / 2^q +-- +-- While (u, v, w) are n-bit numbers, 5^q and whatnot are significantly larger, +-- but we only need the top-most n bits of the result so we can choose `k` that +-- reduce the number of bits required to ~2n. We then multiply by either +-- +-- 2^k / 5^q OR 5^-e2-q / 2^k +-- +-- The required `k` is roughly linear in the exponent (we need more of the +-- multiplication to be precise) but the number of bits to store the +-- multiplicands above stays fixed. +-- +-- Since the number of bits needed is relatively small for IEEE 32- and 64-bit +-- floating types, we can compute appropriate values for `k` for the +-- floating-point-type-specific bounds instead of each e2. +-- +-- Finally, we need to do some final manual iterations potentially to do a +-- final fixup of the skipped state + + +-- | Bound for bits of @2^k / 5^q@ for floats +float_pow5_inv_bitcount :: Int +float_pow5_inv_bitcount = 59 + +-- | Bound for bits of @5^-e2-q / 2^k@ for floats +float_pow5_bitcount :: Int +float_pow5_bitcount = 61 + +-- | Bound for bits of @5^-e2-q / 2^k@ for doubles +double_pow5_bitcount :: Int +double_pow5_bitcount = 125 + +-- | Bound for bits of @2^k / 5^q@ for doubles +double_pow5_inv_bitcount :: Int +double_pow5_inv_bitcount = 125 + +-- NB: these tables are encoded directly into the +-- source code in cbits/aligned-static-hs-data.c + +-- | Number of bits in a positive integer +blen :: Integer -> Int +blen 0 = 0 +blen 1 = 1 +blen n = 1 + blen (n `quot` 2) + +-- | Used for table generation of 2^k / 5^q + 1 +finv :: Int -> Int -> Integer +finv bitcount i = + let p = 5^i + in (1 `shiftL` (blen p - 1 + bitcount)) `div` p + 1 + +-- | Used for table generation of 5^-e2-q / 2^k +fnorm :: Int -> Int -> Integer +fnorm bitcount i = + let p = 5^i + s = blen p - bitcount + in if s < 0 then p `shiftL` (-s) else p `shiftR` s + +-- | Breaks each integer into two Word64s (lowBits, highBits) +splitWord128s :: [Integer] -> [Word64] +splitWord128s li + = [fromInteger w | x <- li, w <- [x .&. maxWord64, x `shiftR` 64]] + where maxWord64 = toInteger (maxBound :: Word64) + +splitWord128 :: Integer -> (Word64,Word64) +splitWord128 x = (fromInteger (x `shiftR` 64), fromInteger (x .&. maxWord64)) + where maxWord64 = toInteger (maxBound :: Word64) + + +-- Helpers to generate case alternatives returning either one Word64 (case64) or +-- two Word64s (case128) for the PURE_HASKELL variant of the tables. +case64 :: (Int -> Integer) -> [Int] -> String +case64 f range = concat + [ show i ++ " -> 0x" ++ showHex (f i) "\n" + | i <- range] + +case128 :: (Int -> Integer) -> [Int] -> String +case128 f range = concat + [ show i ++ " -> (0x" ++ showHex hi "" ++ ", 0x" ++ showHex lo ")\n" + | i <- range + , let (hi,lo) = splitWord128 (f i) + ] + +-- Given a specific floating-point type, determine the range of q for the < 0 +-- and >= 0 cases +get_range :: forall ff. (RealFloat ff) => ff -> (Int, Int) +get_range f = + let (emin, emax) = floatRange f + mantissaDigits = floatDigits f + emin' = emin - mantissaDigits - 2 + emax' = emax - mantissaDigits - 2 + in ( (-emin') - floor (int2Double (-emin') * logBase 10 5) + , floor (int2Double emax' * logBase 10 2)) + +float_max_split :: Int -- = 46 +float_max_inv_split :: Int -- = 30 +(float_max_split, float_max_inv_split) = get_range (undefined :: Float) + +-- we take a slightly different codepath s.t we need one extra entry +double_max_split :: Int -- = 325 +double_max_inv_split :: Int -- = 291 +(double_max_split, double_max_inv_split) = + let (m, mi) = get_range (undefined :: Double) + in (m + 1, mi) + diff --git a/Data/ByteString/Char8.hs b/Data/ByteString/Char8.hs --- a/Data/ByteString/Char8.hs +++ b/Data/ByteString/Char8.hs @@ -1,12 +1,10 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ -{-# LANGUAGE MagicHash, UnboxedTuples #-} -#endif -{-# OPTIONS_HADDOCK prune #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif +{-# OPTIONS_HADDOCK prune #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + -- We use the deprecated Data.ByteString.{hGetLine,getLine} to + -- define the not-deprecated Char8 versions of the same functions. + -- | -- Module : Data.ByteString.Char8 -- Copyright : (c) Don Stewart 2006-2008 @@ -24,9 +22,9 @@ -- More specifically these byte strings are taken to be in the -- subset of Unicode covered by code points 0-255. This covers -- Unicode Basic Latin, Latin-1 Supplement and C0+C1 Controls. --- --- See: -- +-- See: +-- -- * -- -- * @@ -47,149 +45,176 @@ module Data.ByteString.Char8 ( -- * The @ByteString@ type - ByteString, -- abstract, instances: Eq, Ord, Show, Read, Data, Typeable, Monoid + ByteString, -- * Introducing and eliminating 'ByteString's - empty, -- :: ByteString - singleton, -- :: Char -> ByteString - pack, -- :: String -> ByteString - unpack, -- :: ByteString -> String + empty, + singleton, + pack, + unpack, + B.fromStrict, + B.toStrict, -- * Basic interface - cons, -- :: Char -> ByteString -> ByteString - snoc, -- :: ByteString -> Char -> ByteString - append, -- :: ByteString -> ByteString -> ByteString - head, -- :: ByteString -> Char - uncons, -- :: ByteString -> Maybe (Char, ByteString) - last, -- :: ByteString -> Char - tail, -- :: ByteString -> ByteString - init, -- :: ByteString -> ByteString - null, -- :: ByteString -> Bool - length, -- :: ByteString -> Int + cons, + snoc, + append, + head, + uncons, + unsnoc, + last, + tail, + init, + null, + length, - -- * Transformating ByteStrings - map, -- :: (Char -> Char) -> ByteString -> ByteString - reverse, -- :: ByteString -> ByteString - intersperse, -- :: Char -> ByteString -> ByteString - intercalate, -- :: ByteString -> [ByteString] -> ByteString - transpose, -- :: [ByteString] -> [ByteString] + -- * Transforming ByteStrings + map, + reverse, + intersperse, + intercalate, + transpose, -- * Reducing 'ByteString's (folds) - foldl, -- :: (a -> Char -> a) -> a -> ByteString -> a - foldl', -- :: (a -> Char -> a) -> a -> ByteString -> a - foldl1, -- :: (Char -> Char -> Char) -> ByteString -> Char - foldl1', -- :: (Char -> Char -> Char) -> ByteString -> Char + foldl, + foldl', + foldl1, + foldl1', - foldr, -- :: (Char -> a -> a) -> a -> ByteString -> a - foldr', -- :: (Char -> a -> a) -> a -> ByteString -> a - foldr1, -- :: (Char -> Char -> Char) -> ByteString -> Char - foldr1', -- :: (Char -> Char -> Char) -> ByteString -> Char + foldr, + foldr', + foldr1, + foldr1', -- ** Special folds - concat, -- :: [ByteString] -> ByteString - concatMap, -- :: (Char -> ByteString) -> ByteString -> ByteString - any, -- :: (Char -> Bool) -> ByteString -> Bool - all, -- :: (Char -> Bool) -> ByteString -> Bool - maximum, -- :: ByteString -> Char - minimum, -- :: ByteString -> Char + concat, + concatMap, + any, + all, + maximum, + minimum, -- * Building ByteStrings -- ** Scans - scanl, -- :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString - scanl1, -- :: (Char -> Char -> Char) -> ByteString -> ByteString - scanr, -- :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString - scanr1, -- :: (Char -> Char -> Char) -> ByteString -> ByteString + scanl, + scanl1, + scanr, + scanr1, -- ** Accumulating maps - mapAccumL, -- :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString) - mapAccumR, -- :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString) + mapAccumL, + mapAccumR, -- ** Generating and unfolding ByteStrings - replicate, -- :: Int -> Char -> ByteString - unfoldr, -- :: (a -> Maybe (Char, a)) -> a -> ByteString - unfoldrN, -- :: Int -> (a -> Maybe (Char, a)) -> a -> (ByteString, Maybe a) + replicate, + unfoldr, + unfoldrN, -- * Substrings -- ** Breaking strings - take, -- :: Int -> ByteString -> ByteString - drop, -- :: Int -> ByteString -> ByteString - splitAt, -- :: Int -> ByteString -> (ByteString, ByteString) - takeWhile, -- :: (Char -> Bool) -> ByteString -> ByteString - dropWhile, -- :: (Char -> Bool) -> ByteString -> ByteString - span, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) - spanEnd, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) - break, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) - breakEnd, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) - group, -- :: ByteString -> [ByteString] - groupBy, -- :: (Char -> Char -> Bool) -> ByteString -> [ByteString] - inits, -- :: ByteString -> [ByteString] - tails, -- :: ByteString -> [ByteString] + take, + takeEnd, + drop, + dropEnd, + splitAt, + takeWhile, + takeWhileEnd, + dropWhile, + dropWhileEnd, + dropSpace, + span, + spanEnd, + break, + breakEnd, + group, + groupBy, + inits, + tails, + initsNE, + tailsNE, + strip, + stripPrefix, + stripSuffix, -- ** Breaking into many substrings - split, -- :: Char -> ByteString -> [ByteString] - splitWith, -- :: (Char -> Bool) -> ByteString -> [ByteString] + split, + splitWith, -- ** Breaking into lines and words - lines, -- :: ByteString -> [ByteString] - words, -- :: ByteString -> [ByteString] - unlines, -- :: [ByteString] -> ByteString - unwords, -- :: ByteString -> [ByteString] + lines, + words, + unlines, + unwords, -- * Predicates - isPrefixOf, -- :: ByteString -> ByteString -> Bool - isSuffixOf, -- :: ByteString -> ByteString -> Bool - isInfixOf, -- :: ByteString -> ByteString -> Bool + isPrefixOf, + isSuffixOf, + isInfixOf, -- ** Search for arbitrary substrings - breakSubstring, -- :: ByteString -> ByteString -> (ByteString,ByteString) - findSubstring, -- :: ByteString -> ByteString -> Maybe Int - findSubstrings, -- :: ByteString -> ByteString -> [Int] + breakSubstring, -- * Searching ByteStrings -- ** Searching by equality - elem, -- :: Char -> ByteString -> Bool - notElem, -- :: Char -> ByteString -> Bool + elem, + notElem, -- ** Searching with a predicate - find, -- :: (Char -> Bool) -> ByteString -> Maybe Char - filter, -- :: (Char -> Bool) -> ByteString -> ByteString --- partition -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) + find, + filter, + partition, -- * Indexing ByteStrings - index, -- :: ByteString -> Int -> Char - elemIndex, -- :: Char -> ByteString -> Maybe Int - elemIndices, -- :: Char -> ByteString -> [Int] - elemIndexEnd, -- :: Char -> ByteString -> Maybe Int - findIndex, -- :: (Char -> Bool) -> ByteString -> Maybe Int - findIndices, -- :: (Char -> Bool) -> ByteString -> [Int] - count, -- :: Char -> ByteString -> Int + index, + indexMaybe, + (!?), + elemIndex, + elemIndices, + elemIndexEnd, + findIndex, + findIndices, + findIndexEnd, + count, -- * Zipping and unzipping ByteStrings - zip, -- :: ByteString -> ByteString -> [(Char,Char)] - zipWith, -- :: (Char -> Char -> c) -> ByteString -> ByteString -> [c] - unzip, -- :: [(Char,Char)] -> (ByteString,ByteString) + zip, + zipWith, + packZipWith, + unzip, -- * Ordered ByteStrings - sort, -- :: ByteString -> ByteString + sort, -- * Reading from ByteStrings - readInt, -- :: ByteString -> Maybe (Int, ByteString) - readInteger, -- :: ByteString -> Maybe (Integer, ByteString) + readInt, + readInt64, + readInt32, + readInt16, + readInt8, + readWord, + readWord64, + readWord32, + readWord16, + readWord8, + + readInteger, + readNatural, + -- * Low level CString conversions -- ** Copying ByteStrings - copy, -- :: ByteString -> ByteString + copy, -- ** Packing CStrings and pointers - packCString, -- :: CString -> IO ByteString - packCStringLen, -- :: CStringLen -> IO ByteString + packCString, + packCStringLen, -- ** Using ByteStrings as CStrings - useAsCString, -- :: ByteString -> (CString -> IO a) -> IO a - useAsCStringLen, -- :: ByteString -> (CStringLen -> IO a) -> IO a + useAsCString, + useAsCStringLen, -- * I\/O with 'ByteString's -- | ByteString I/O uses binary mode, without any character decoding @@ -197,39 +222,40 @@ -- newline mode is considered a flaw and may be changed in a future version. -- ** Standard input and output - getLine, -- :: IO ByteString - getContents, -- :: IO ByteString - putStr, -- :: ByteString -> IO () - putStrLn, -- :: ByteString -> IO () - interact, -- :: (ByteString -> ByteString) -> IO () + getLine, + getContents, + putStr, + putStrLn, + interact, -- ** Files - readFile, -- :: FilePath -> IO ByteString - writeFile, -- :: FilePath -> ByteString -> IO () - appendFile, -- :: FilePath -> ByteString -> IO () --- mmapFile, -- :: FilePath -> IO ByteString + readFile, + writeFile, + appendFile, +-- mmapFile, -- ** I\/O with Handles - hGetLine, -- :: Handle -> IO ByteString - hGetContents, -- :: Handle -> IO ByteString - hGet, -- :: Handle -> Int -> IO ByteString - hGetNonBlocking, -- :: Handle -> Int -> IO ByteString - hPut, -- :: Handle -> ByteString -> IO () - hPutNonBlocking, -- :: Handle -> ByteString -> IO ByteString - hPutStr, -- :: Handle -> ByteString -> IO () - hPutStrLn, -- :: Handle -> ByteString -> IO () + hGetLine, + hGetContents, + hGet, + hGetSome, + hGetNonBlocking, + hPut, + hPutNonBlocking, + hPutStr, + hPutStrLn, ) where import qualified Prelude as P -import Prelude hiding (reverse,head,tail,last,init,null - ,length,map,lines,foldl,foldr,unlines +import Prelude hiding (reverse,head,tail,last,init,Foldable(..) + ,map,lines,unlines ,concat,any,take,drop,splitAt,takeWhile - ,dropWhile,span,break,elem,filter,unwords - ,words,maximum,minimum,all,concatMap + ,dropWhile,span,break,filter,unwords + ,words,all,concatMap ,scanl,scanl1,scanr,scanr1 ,appendFile,readFile,writeFile - ,foldl1,foldr1,replicate + ,replicate ,getContents,getLine,putStr,putStrLn,interact ,zip,zipWith,unzip,notElem) @@ -238,36 +264,33 @@ import qualified Data.ByteString.Unsafe as B -- Listy functions transparently exported -import Data.ByteString (empty,null,length,tail,init,append - ,inits,tails,reverse,transpose - ,concat,take,drop,splitAt,intercalate - ,sort,isPrefixOf,isSuffixOf,isInfixOf - ,findSubstring,findSubstrings,breakSubstring,copy,group +import Data.ByteString (null,length,tail,init,append + ,inits,tails,initsNE,tailsNE,reverse,transpose + ,concat,take,takeEnd,drop,dropEnd,splitAt + ,intercalate,sort,isPrefixOf,isSuffixOf + ,isInfixOf,stripPrefix,stripSuffix + ,breakSubstring,copy,group - ,getLine, getContents, putStr, interact - ,hGetContents, hGet, hPut, hPutStr - ,hGetLine, hGetNonBlocking, hPutNonBlocking + ,getContents, putStr, interact + ,readFile, writeFile, appendFile + ,hGetContents, hGet, hGetSome, hPut, hPutStr + ,hGetNonBlocking, hPutNonBlocking ,packCString,packCStringLen ,useAsCString,useAsCStringLen ) -import Data.ByteString.Internal +import Data.ByteString.Internal.Type +import Data.ByteString.ReadInt +import Data.ByteString.ReadNat import Data.Char ( isSpace ) -import qualified Data.List as List (intersperse) +-- See bytestring #70 +import GHC.Char (eqChar) +import qualified Data.List as List -import System.IO (Handle,stdout,openFile,hClose,hFileSize,IOMode(..)) -#ifndef __NHC__ -import Control.Exception (bracket) -#else -import IO (bracket) -#endif +import System.IO (Handle,stdout) import Foreign -#define STRICT1(f) f a | a `seq` False = undefined -#define STRICT2(f) f a b | a `seq` b `seq` False = undefined -#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined -#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined ------------------------------------------------------------------------ @@ -282,16 +305,7 @@ -- bottleneck. pack :: String -> ByteString pack = packChars - -#if !defined(__GLASGOW_HASKELL__) -{-# INLINE [1] pack #-} - -{-# RULES -"ByteString pack/packAddress" forall s . - pack (unpackCString# s) = inlinePerformIO (B.unsafePackAddress s) - #-} - -#endif +{-# INLINE pack #-} -- | /O(n)/ Converts a 'ByteString' to a 'String'. unpack :: ByteString -> [Char] @@ -321,6 +335,14 @@ Just (w, bs') -> Just (w2c w, bs') {-# INLINE uncons #-} +-- | /O(1)/ Extract the 'init' and 'last' of a ByteString, returning Nothing +-- if it is empty. +unsnoc :: ByteString -> Maybe (ByteString, Char) +unsnoc bs = case B.unsnoc bs of + Nothing -> Nothing + Just (bs', w) -> Just (bs', w2c w) +{-# INLINE unsnoc #-} + -- | /O(1)/ Extract the first element of a ByteString, which must be non-empty. head :: ByteString -> Char head = w2c . B.head @@ -350,7 +372,7 @@ foldl f = B.foldl (\a c -> f a (w2c c)) {-# INLINE foldl #-} --- | 'foldl\'' is like foldl, but strict in the accumulator. +-- | 'foldl'' is like foldl, but strict in the accumulator. foldl' :: (a -> Char -> a) -> a -> ByteString -> a foldl' f = B.foldl' (\a c -> f a (w2c c)) {-# INLINE foldl' #-} @@ -359,16 +381,16 @@ -- (typically the right-identity of the operator), and a packed string, -- reduces the packed string using the binary operator, from right to left. foldr :: (Char -> a -> a) -> a -> ByteString -> a -foldr f = B.foldr (\c a -> f (w2c c) a) +foldr f = B.foldr (f . w2c) {-# INLINE foldr #-} --- | 'foldr\'' is a strict variant of foldr +-- | 'foldr'' is a strict variant of foldr foldr' :: (Char -> a -> a) -> a -> ByteString -> a -foldr' f = B.foldr' (\c a -> f (w2c c) a) +foldr' f = B.foldr' (f . w2c) {-# INLINE foldr' #-} -- | 'foldl1' is a variant of 'foldl' that has no starting value --- argument, and thus must be applied to non-empty 'ByteStrings'. +-- argument, and thus must be applied to non-empty 'ByteString's. foldl1 :: (Char -> Char -> Char) -> ByteString -> Char foldl1 f ps = w2c (B.foldl1 (\x y -> c2w (f (w2c x) (w2c y))) ps) {-# INLINE foldl1 #-} @@ -419,7 +441,7 @@ -- | The 'mapAccumL' function behaves like a combination of 'map' and -- 'foldl'; it applies a function to each element of a ByteString, -- passing an accumulating parameter from left to right, and returning a --- final value of this accumulator together with the new list. +-- final value of this accumulator together with the new ByteString. mapAccumL :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString) mapAccumL f = B.mapAccumL (\acc w -> case f acc (w2c w) of (acc', c) -> (acc', c2w c)) @@ -460,23 +482,23 @@ -- -- > replicate w c = unfoldr w (\u -> Just (u,u)) c -- --- This implemenation uses @memset(3)@ +-- This implementation uses @memset(3)@ replicate :: Int -> Char -> ByteString -replicate w = B.replicate w . c2w +replicate n = B.replicate n . c2w {-# INLINE replicate #-} --- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' --- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a --- ByteString from a seed value. The function takes the element and --- returns 'Nothing' if it is done producing the ByteString or returns --- 'Just' @(a,b)@, in which case, @a@ is the next character in the string, +-- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' +-- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a +-- ByteString from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the ByteString or returns +-- 'Just' @(a,b)@, in which case, @a@ is the next character in the string, -- and @b@ is the seed value for further production. -- -- Examples: -- -- > unfoldr (\x -> if x <= '9' then Just (x, succ x) else Nothing) '0' == "0123456789" unfoldr :: (a -> Maybe (Char, a)) -> a -> ByteString -unfoldr f x0 = B.unfoldr (fmap k . f) x0 +unfoldr f = B.unfoldr (fmap k . f) where k (i, j) = (c2w i, j) -- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a ByteString from a seed @@ -488,7 +510,7 @@ -- -- > unfoldrN n f s == take n (unfoldr f s) unfoldrN :: Int -> (a -> Maybe (Char, a)) -> a -> (ByteString, Maybe a) -unfoldrN n f w = B.unfoldrN n ((k `fmap`) . f) w +unfoldrN n f = B.unfoldrN n ((k `fmap`) . f) where k (i,j) = (c2w i, j) {-# INLINE unfoldrN #-} @@ -499,38 +521,52 @@ takeWhile f = B.takeWhile (f . w2c) {-# INLINE takeWhile #-} +-- | 'takeWhileEnd', applied to a predicate @p@ and a ByteString @xs@, +-- returns the longest suffix (possibly empty) of @xs@ of elements that +-- satisfy @p@. +-- +-- @since 0.10.12.0 +takeWhileEnd :: (Char -> Bool) -> ByteString -> ByteString +takeWhileEnd f = B.takeWhileEnd (f . w2c) +{-# INLINE takeWhileEnd #-} + -- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@. dropWhile :: (Char -> Bool) -> ByteString -> ByteString dropWhile f = B.dropWhile (f . w2c) -#if defined(__GLASGOW_HASKELL__) {-# INLINE [1] dropWhile #-} -#endif {-# RULES "ByteString specialise dropWhile isSpace -> dropSpace" dropWhile isSpace = dropSpace #-} +-- | 'dropWhileEnd' @p xs@ returns the prefix remaining after 'takeWhileEnd' @p +-- xs@. +-- +-- @since 0.10.12.0 +dropWhileEnd :: (Char -> Bool) -> ByteString -> ByteString +dropWhileEnd f = B.dropWhileEnd (f . w2c) +{-# INLINE dropWhileEnd #-} + -- | 'break' @p@ is equivalent to @'span' ('not' . p)@. break :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) break f = B.break (f . w2c) -#if defined(__GLASGOW_HASKELL__) {-# INLINE [1] break #-} -#endif +-- See bytestring #70 {-# RULES "ByteString specialise break (x==)" forall x. - break ((==) x) = breakChar x + break (x `eqChar`) = breakChar x "ByteString specialise break (==x)" forall x. - break (==x) = breakChar x + break (`eqChar` x) = breakChar x #-} -- INTERNAL: --- | 'breakChar' breaks its ByteString argument at the first occurence +-- | 'breakChar' breaks its ByteString argument at the first occurrence -- of the specified char. It is more efficient than 'break' as it is -- implemented with @memchr(3)@. I.e. --- +-- -- > break (=='c') "abcd" == breakChar 'c' "abcd" -- breakChar :: Char -> ByteString -> (ByteString, ByteString) @@ -553,56 +589,35 @@ -- and -- -- > spanEnd (not . isSpace) ps --- > == --- > let (x,y) = span (not.isSpace) (reverse ps) in (reverse y, reverse x) +-- > == +-- > let (x,y) = span (not.isSpace) (reverse ps) in (reverse y, reverse x) -- spanEnd :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) spanEnd f = B.spanEnd (f . w2c) {-# INLINE spanEnd #-} -- | 'breakEnd' behaves like 'break' but from the end of the 'ByteString' --- +-- -- breakEnd p == spanEnd (not.p) breakEnd :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) breakEnd f = B.breakEnd (f . w2c) {-# INLINE breakEnd #-} -{- --- | 'breakChar' breaks its ByteString argument at the first occurence --- of the specified Char. It is more efficient than 'break' as it is --- implemented with @memchr(3)@. I.e. --- --- > break (=='c') "abcd" == breakChar 'c' "abcd" --- -breakChar :: Char -> ByteString -> (ByteString, ByteString) -breakChar = B.breakByte . c2w -{-# INLINE breakChar #-} - --- | 'spanChar' breaks its ByteString argument at the first --- occurence of a Char other than its argument. It is more efficient --- than 'span (==)' --- --- > span (=='c') "abcd" == spanByte 'c' "abcd" --- -spanChar :: Char -> ByteString -> (ByteString, ByteString) -spanChar = B.spanByte . c2w -{-# INLINE spanChar #-} --} - -- | /O(n)/ Break a 'ByteString' into pieces separated by the byte -- argument, consuming the delimiter. I.e. -- -- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"] -- > split 'a' "aXaXaXa" == ["","X","X","X",""] -- > split 'x' "x" == ["",""] --- +-- > split undefined "" == [] -- and not [""] +-- -- and -- -- > intercalate [c] . split c == id -- > split == splitWith . (==) --- +-- -- As for all splitting functions in this library, this function does --- not copy the substrings, it just constructs new 'ByteStrings' that +-- not copy the substrings, it just constructs new 'ByteString's that -- are slices of the original. -- split :: Char -> ByteString -> [ByteString] @@ -615,6 +630,7 @@ -- separators result in an empty component in the output. eg. -- -- > splitWith (=='a') "aabbaca" == ["","","bb","c",""] +-- > splitWith undefined "" == [] -- and not [""] -- splitWith :: (Char -> Bool) -> ByteString -> [ByteString] splitWith f = B.splitWith (f . w2c) @@ -624,7 +640,7 @@ {- -- | Like 'splitWith', except that sequences of adjacent separators are -- treated as a single separator. eg. --- +-- -- > tokens (=='a') "aabbaca" == ["bb","c"] -- tokens :: (Char -> Bool) -> ByteString -> [ByteString] @@ -641,6 +657,24 @@ index = (w2c .) . B.index {-# INLINE index #-} +-- | /O(1)/ 'ByteString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 0.11.0.0 +indexMaybe :: ByteString -> Int -> Maybe Char +indexMaybe = (fmap w2c .) . B.indexMaybe +{-# INLINE indexMaybe #-} + +-- | /O(1)/ 'ByteString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 0.11.0.0 +(!?) :: ByteString -> Int -> Maybe Char +(!?) = indexMaybe +{-# INLINE (!?) #-} + -- | /O(n)/ The 'elemIndex' function returns the index of the first -- element in the given 'ByteString' which is equal (by memchr) to the -- query element, or 'Nothing' if there is no such element. @@ -653,8 +687,9 @@ -- element, or 'Nothing' if there is no such element. The following -- holds: -- --- > elemIndexEnd c xs == --- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs) +-- > elemIndexEnd c xs = case elemIndex c (reverse xs) of +-- > Nothing -> Nothing +-- > Just i -> Just (length xs - 1 - i) -- elemIndexEnd :: Char -> ByteString -> Maybe Int elemIndexEnd = B.elemIndexEnd . c2w @@ -670,19 +705,41 @@ -- returns the index of the first element in the ByteString satisfying the predicate. findIndex :: (Char -> Bool) -> ByteString -> Maybe Int findIndex f = B.findIndex (f . w2c) -{-# INLINE findIndex #-} +{-# INLINE [1] findIndex #-} +-- | /O(n)/ The 'findIndexEnd' function takes a predicate and a 'ByteString' and +-- returns the index of the last element in the ByteString +-- satisfying the predicate. +-- +-- @since 0.11.1.0 +findIndexEnd :: (Char -> Bool) -> ByteString -> Maybe Int +findIndexEnd f = B.findIndexEnd (f . w2c) +{-# INLINE [1] findIndexEnd #-} + -- | The 'findIndices' function extends 'findIndex', by returning the -- indices of all elements satisfying the predicate, in ascending order. findIndices :: (Char -> Bool) -> ByteString -> [Int] findIndices f = B.findIndices (f . w2c) +{-# INLINE [1] findIndices #-} +{-# RULES +"ByteString specialise findIndex (x==)" forall x. + findIndex (x `eqChar`) = elemIndex x +"ByteString specialise findIndex (==x)" forall x. + findIndex (`eqChar` x) = elemIndex x +"ByteString specialise findIndices (x==)" forall x. + findIndices (x `eqChar`) = elemIndices x +"ByteString specialise findIndices (==x)" forall x. + findIndices (`eqChar` x) = elemIndices x + #-} + + -- | count returns the number of times its argument appears in the ByteString -- -- > count = length . elemIndices --- +-- -- Also --- +-- -- > count '\n' == length . lines -- -- But more efficiently than using length on the intermediate list. @@ -707,6 +764,11 @@ filter f = B.filter (f . w2c) {-# INLINE filter #-} +-- | @since 0.10.12.0 +partition :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) +partition f = B.partition (f . w2c) +{-# INLINE partition #-} + {- -- | /O(n)/ and /O(n\/c) space/ A first order equivalent of /filter . -- (==)/, for the common case of filtering a single Char. It is more @@ -770,9 +832,11 @@ -- equivalent to a pair of 'unpack' operations, and so space -- usage may be large for multi-megabyte ByteStrings zip :: ByteString -> ByteString -> [(Char,Char)] -zip ps qs - | B.null ps || B.null qs = [] - | otherwise = (unsafeHead ps, unsafeHead qs) : zip (B.unsafeTail ps) (B.unsafeTail qs) +zip ps qs = case uncons ps of + Nothing -> [] + Just (psH, psT) -> case uncons qs of + Nothing -> [] + Just (qsH, qsT) -> (psH, qsH) : zip psT qsT -- | 'zipWith' generalises 'zip' by zipping with the function given as -- the first argument, instead of a tupling function. For example, @@ -781,20 +845,22 @@ zipWith :: (Char -> Char -> a) -> ByteString -> ByteString -> [a] zipWith f = B.zipWith ((. w2c) . f . w2c) +-- | A specialised version of `zipWith` for the common case of a +-- simultaneous map over two ByteStrings, to build a 3rd. +-- +-- @since 0.11.1.0 +packZipWith :: (Char -> Char -> Char) -> ByteString -> ByteString -> ByteString +packZipWith f = B.packZipWith f' + where + f' c1 c2 = c2w $ f (w2c c1) (w2c c2) +{-# INLINE packZipWith #-} + -- | 'unzip' transforms a list of pairs of Chars into a pair of -- ByteStrings. Note that this performs two 'pack' operations. unzip :: [(Char,Char)] -> (ByteString,ByteString) unzip ls = (pack (P.map fst ls), pack (P.map snd ls)) {-# INLINE unzip #-} --- | A variety of 'head' for non-empty ByteStrings. 'unsafeHead' omits --- the check for the empty case, which is good for performance, but --- there is an obligation on the programmer to provide a proof that the --- ByteString is non-empty. -unsafeHead :: ByteString -> Char -unsafeHead = w2c . B.unsafeHead -{-# INLINE unsafeHead #-} - -- --------------------------------------------------------------------- -- Things that depend on the encoding @@ -805,22 +871,21 @@ -- | 'breakSpace' returns the pair of ByteStrings when the argument is -- broken at the first whitespace byte. I.e. --- +-- -- > break isSpace == breakSpace -- breakSpace :: ByteString -> (ByteString,ByteString) -breakSpace (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do - i <- firstspace (p `plusPtr` s) 0 l +breakSpace (BS x l) = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> do + i <- firstspace p 0 l return $! case () of {_ - | i == 0 -> (empty, PS x s l) - | i == l -> (PS x s l, empty) - | otherwise -> (PS x s i, PS x (s+i) (l-i)) + | i == 0 -> (empty, BS x l) + | i == l -> (BS x l, empty) + | otherwise -> (BS x i, BS (plusForeignPtr x i) (l-i)) } {-# INLINE breakSpace #-} firstspace :: Ptr Word8 -> Int -> Int -> IO Int -STRICT3(firstspace) -firstspace ptr n m +firstspace !ptr !n !m | n >= m = return n | otherwise = do w <- peekByteOff ptr n if (not . isSpaceWord8) w then firstspace ptr (n+1) m else return n @@ -828,38 +893,43 @@ -- | 'dropSpace' efficiently returns the 'ByteString' argument with -- white space Chars removed from the front. It is more efficient than -- calling dropWhile for removing whitespace. I.e. --- +-- -- > dropWhile isSpace == dropSpace -- +-- @since 0.10.12.0 dropSpace :: ByteString -> ByteString -dropSpace (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do - i <- firstnonspace (p `plusPtr` s) 0 l - return $! if i == l then empty else PS x (s+i) (l-i) +dropSpace (BS x l) = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> do + i <- firstnonspace p 0 l + return $! if i == l then empty else BS (plusForeignPtr x i) (l-i) {-# INLINE dropSpace #-} firstnonspace :: Ptr Word8 -> Int -> Int -> IO Int -STRICT3(firstnonspace) -firstnonspace ptr n m +firstnonspace !ptr !n !m | n >= m = return n | otherwise = do w <- peekElemOff ptr n if isSpaceWord8 w then firstnonspace ptr (n+1) m else return n +-- | Remove leading and trailing white space from a 'ByteString'. +-- +-- @since 0.10.12.0 +strip :: ByteString -> ByteString +strip = dropWhile isSpace . dropWhileEnd isSpace + {- -- | 'dropSpaceEnd' efficiently returns the 'ByteString' argument with -- white space removed from the end. I.e. --- +-- -- > reverse . (dropWhile isSpace) . reverse == dropSpaceEnd -- -- but it is more efficient than using multiple reverses. -- dropSpaceEnd :: ByteString -> ByteString -dropSpaceEnd (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do - i <- lastnonspace (p `plusPtr` s) (l-1) - return $! if i == (-1) then empty else PS x s (i+1) +dropSpaceEnd (BS x l) = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> do + i <- lastnonspace p (l-1) + return $! if i == (-1) then empty else BS x (i+1) {-# INLINE dropSpaceEnd #-} lastnonspace :: Ptr Word8 -> Int -> IO Int -STRICT2(lastnonspace) lastnonspace ptr n | n < 0 = return n | otherwise = do w <- peekElemOff ptr n @@ -867,8 +937,10 @@ -} -- | 'lines' breaks a ByteString up into a list of ByteStrings at --- newline Chars. The resulting strings do not contain newlines. +-- newline Chars (@'\\n'@). The resulting strings do not contain newlines. -- +-- Note that it __does not__ regard CR (@'\\r'@) as a newline character. +-- lines :: ByteString -> [ByteString] lines ps | null ps = [] @@ -878,30 +950,41 @@ where search = elemIndex '\n' {- --- Just as fast, but more complex. Should be much faster, I thought. -lines :: ByteString -> [ByteString] -lines (PS _ _ 0) = [] -lines (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do - let ptr = p `plusPtr` s - - STRICT1(loop) - loop n = do - let q = memchr (ptr `plusPtr` n) 0x0a (fromIntegral (l-n)) - if q == nullPtr - then return [PS x (s+n) (l-n)] - else do let i = q `minusPtr` ptr - ls <- loop (i+1) - return $! PS x (s+n) (i-n) : ls - loop 0 +-- Could be faster, now passes tests... +lines (BS _ 0) = [] +lines (BS x l) = go x l + where + nl = c2w '\n' + -- It is important to remain lazy in the tail of the list. The caller + -- might only want the first few lines. + go !f !len = accursedUnutterablePerformIO $ unsafeWithForeignPtr f $ \p -> do + q <- memchr p nl $! fromIntegral len + if q == nullPtr + then return [BS f len] + else do + let !i = q `minusPtr` p + !j = i + 1 + if j < len + then return $ BS f i : go (plusForeignPtr f j) (len - j) + else return [BS f i] -} --- | 'unlines' is an inverse operation to 'lines'. It joins lines, --- after appending a terminating newline to each. +-- | 'unlines' joins lines, appending a terminating newline after each. +-- +-- Equivalent to +-- @'concat' . Data.List.concatMap (\\x -> [x, 'singleton' \'\\n'])@. unlines :: [ByteString] -> ByteString -unlines [] = empty -unlines ss = (concat $ List.intersperse nl ss) `append` nl -- half as much space - where nl = singleton '\n' +unlines = \li -> let + totLen = List.foldl' (\acc s -> acc +! length s +! 1) 0 li + (+!) = checkedAdd "Char8.unlines" + go [] _ = pure () + go (BS src len : srcs) dest = do + memcpyFp dest src len + pokeFpByteOff dest len (c2w '\n') + go srcs $ dest `plusForeignPtr` (len + 1) + in unsafeCreateFp totLen (go li) + -- | 'words' breaks a ByteString up into a list of words, which -- were delimited by Chars representing white space. words :: ByteString -> [ByteString] @@ -913,110 +996,31 @@ unwords = intercalate (singleton ' ') {-# INLINE unwords #-} --- --------------------------------------------------------------------- --- Reading from ByteStrings - --- | readInt reads an Int from the beginning of the ByteString. If there is no --- integer at the beginning of the string, it returns Nothing, otherwise --- it just returns the int read, and the rest of the string. -readInt :: ByteString -> Maybe (Int, ByteString) -readInt as - | null as = Nothing - | otherwise = - case unsafeHead as of - '-' -> loop True 0 0 (B.unsafeTail as) - '+' -> loop False 0 0 (B.unsafeTail as) - _ -> loop False 0 0 as - - where loop :: Bool -> Int -> Int -> ByteString -> Maybe (Int, ByteString) - STRICT4(loop) - loop neg i n ps - | null ps = end neg i n ps - | otherwise = - case B.unsafeHead ps of - w | w >= 0x30 - && w <= 0x39 -> loop neg (i+1) - (n * 10 + (fromIntegral w - 0x30)) - (B.unsafeTail ps) - | otherwise -> end neg i n ps - - end _ 0 _ _ = Nothing - end True _ n ps = Just (negate n, ps) - end _ _ n ps = Just (n, ps) - --- | readInteger reads an Integer from the beginning of the ByteString. If --- there is no integer at the beginning of the string, it returns Nothing, --- otherwise it just returns the int read, and the rest of the string. -readInteger :: ByteString -> Maybe (Integer, ByteString) -readInteger as - | null as = Nothing - | otherwise = - case unsafeHead as of - '-' -> first (B.unsafeTail as) >>= \(n, bs) -> return (-n, bs) - '+' -> first (B.unsafeTail as) - _ -> first as - - where first ps | null ps = Nothing - | otherwise = - case B.unsafeHead ps of - w | w >= 0x30 && w <= 0x39 -> Just $ - loop 1 (fromIntegral w - 0x30) [] (B.unsafeTail ps) - | otherwise -> Nothing - - loop :: Int -> Int -> [Integer] - -> ByteString -> (Integer, ByteString) - STRICT4(loop) - loop d acc ns ps - | null ps = combine d acc ns empty - | otherwise = - case B.unsafeHead ps of - w | w >= 0x30 && w <= 0x39 -> - if d == 9 then loop 1 (fromIntegral w - 0x30) - (toInteger acc : ns) - (B.unsafeTail ps) - else loop (d+1) - (10*acc + (fromIntegral w - 0x30)) - ns (B.unsafeTail ps) - | otherwise -> combine d acc ns ps - - combine _ acc [] ps = (toInteger acc, ps) - combine d acc ns ps = - ((10^d * combine1 1000000000 ns + toInteger acc), ps) - - combine1 _ [n] = n - combine1 b ns = combine1 (b*b) $ combine2 b ns - - combine2 b (n:m:ns) = let t = m*b + n in t `seq` (t : combine2 b ns) - combine2 _ ns = ns - ------------------------------------------------------------------------ -- For non-binary text processing: --- | Read an entire file strictly into a 'ByteString'. This is far more --- efficient than reading the characters into a 'String' and then using --- 'pack'. It also may be more efficient than opening the file and --- reading it using hGet. -readFile :: FilePath -> IO ByteString -readFile f = bracket (openFile f ReadMode) hClose - (\h -> hFileSize h >>= hGet h . fromIntegral) - --- | Write a 'ByteString' to a file. -writeFile :: FilePath -> ByteString -> IO () -writeFile f txt = bracket (openFile f WriteMode) hClose - (\h -> hPut h txt) - --- | Append a 'ByteString' to a file. -appendFile :: FilePath -> ByteString -> IO () -appendFile f txt = bracket (openFile f AppendMode) hClose - (\h -> hPut h txt) +-- | Read a line from stdin. +getLine :: IO ByteString +getLine = B.getLine +-- | Read a line from a handle +hGetLine :: Handle -> IO ByteString +hGetLine = B.hGetLine --- | Write a ByteString to a handle, appending a newline byte +-- | Write a ByteString to a handle, appending a newline byte. +-- +-- Unlike 'hPutStr', this is not atomic: other threads might write +-- to the handle between writing of the bytestring and the newline. +-- hPutStrLn :: Handle -> ByteString -> IO () hPutStrLn h ps | length ps < 1024 = hPut h (ps `B.snoc` 0x0a) - | otherwise = hPut h ps >> hPut h (B.singleton (0x0a)) -- don't copy + | otherwise = hPut h ps >> hPut h (B.singleton 0x0a) -- don't copy --- | Write a ByteString to stdout, appending a newline byte +-- | Write a ByteString to 'stdout', appending a newline byte. +-- +-- Unlike 'putStr', this is not atomic: other threads might write +-- to 'stdout' between writing of the bytestring and the newline. +-- putStrLn :: ByteString -> IO () putStrLn = hPutStrLn stdout diff --git a/Data/ByteString/Internal.hs b/Data/ByteString/Internal.hs --- a/Data/ByteString/Internal.hs +++ b/Data/ByteString/Internal.hs @@ -1,14 +1,9 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-} -#if __GLASGOW_HASKELL__ -{-# LANGUAGE UnliftedFFITypes, MagicHash, - UnboxedTuples, DeriveDataTypeable #-} -#endif -{-# OPTIONS_HADDOCK hide #-} +{-# OPTIONS_HADDOCK not-home #-} -- | -- Module : Data.ByteString.Internal -- Copyright : (c) Don Stewart 2006-2008 --- (c) Duncan Coutts 2006-2011 +-- (c) Duncan Coutts 2006-2012 -- License : BSD-style -- Maintainer : dons00@gmail.com, duncan@community.haskell.org -- Stability : unstable @@ -25,558 +20,77 @@ module Data.ByteString.Internal ( -- * The @ByteString@ type and representation - ByteString(..), -- instances: Eq, Ord, Show, Read, Data, Typeable + ByteString + ( BS + , PS -- backwards compatibility shim + ), + StrictByteString, + + -- * Internal indexing + findIndexOrLength, + -- * Conversion with lists: packing and unpacking packBytes, packUptoLenBytes, unsafePackLenBytes, packChars, packUptoLenChars, unsafePackLenChars, unpackBytes, unpackAppendBytesLazy, unpackAppendBytesStrict, unpackChars, unpackAppendCharsLazy, unpackAppendCharsStrict, + unsafePackAddress, unsafePackLenAddress, + unsafePackLiteral, unsafePackLenLiteral, -- * Low level imperative construction - create, -- :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString - createAndTrim, -- :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString - createAndTrim', -- :: Int -> (Ptr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a) - unsafeCreate, -- :: Int -> (Ptr Word8 -> IO ()) -> ByteString - mallocByteString, -- :: Int -> IO (ForeignPtr a) + empty, + create, + createUptoN, + createUptoN', + createAndTrim, + createAndTrim', + unsafeCreate, + unsafeCreateUptoN, + unsafeCreateUptoN', + mallocByteString, -- * Conversion to and from ForeignPtrs - fromForeignPtr, -- :: ForeignPtr Word8 -> Int -> Int -> ByteString - toForeignPtr, -- :: ByteString -> (ForeignPtr Word8, Int, Int) + mkDeferredByteString, + fromForeignPtr, + toForeignPtr, + fromForeignPtr0, + toForeignPtr0, -- * Utilities - inlinePerformIO, -- :: IO a -> a - nullForeignPtr, -- :: ForeignPtr Word8 + nullForeignPtr, + deferForeignPtrAvailability, + SizeOverflowException, + overflowError, + checkedAdd, + checkedMultiply, -- * Standard C Functions - c_strlen, -- :: CString -> IO CInt - c_free_finalizer, -- :: FunPtr (Ptr Word8 -> IO ()) + c_strlen, + c_free_finalizer, - memchr, -- :: Ptr Word8 -> Word8 -> CSize -> IO Ptr Word8 - memcmp, -- :: Ptr Word8 -> Ptr Word8 -> Int -> IO CInt - memcpy, -- :: Ptr Word8 -> Ptr Word8 -> Int -> IO () - memset, -- :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8) + memchr, + memcmp, + memcpy, + memset, -- * cbits functions - c_reverse, -- :: Ptr Word8 -> Ptr Word8 -> CInt -> IO () - c_intersperse, -- :: Ptr Word8 -> Ptr Word8 -> CInt -> Word8 -> IO () - c_maximum, -- :: Ptr Word8 -> CInt -> IO Word8 - c_minimum, -- :: Ptr Word8 -> CInt -> IO Word8 - c_count, -- :: Ptr Word8 -> CInt -> Word8 -> IO CInt + c_reverse, + c_intersperse, + c_maximum, + c_minimum, + c_count, + c_sort, -- * Chars - w2c, c2w, isSpaceWord8, isSpaceChar8 - - ) where - -import Prelude hiding (concat) -import qualified Data.List as List - -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) -import Foreign.Ptr (Ptr, FunPtr, plusPtr) -import Foreign.Storable (Storable(..)) -#if MIN_VERSION_base(4,5,0) || __GLASGOW_HASKELL__ >= 703 -import Foreign.C.Types (CInt(..), CSize(..), CULong(..)) -#else -import Foreign.C.Types (CInt, CSize, CULong) -#endif -import Foreign.C.String (CString) - -import Data.Monoid (Monoid(..)) -import Control.DeepSeq (NFData) - -#if MIN_VERSION_base(3,0,0) -import Data.String (IsString(..)) -#endif - -#ifndef __NHC__ -import Control.Exception (assert) -#endif - -import Data.Char (ord) -import Data.Word (Word8) - -import Data.Typeable (Typeable) -#if MIN_VERSION_base(4,1,0) -import Data.Data (Data(..)) -#if MIN_VERSION_base(4,2,0) -import Data.Data (mkNoRepType) -#else -import Data.Data (mkNorepType) -#endif -#else -import Data.Generics (Data(..), mkNorepType) -#endif - -#ifdef __GLASGOW_HASKELL__ -import GHC.Base (realWorld#,unsafeChr) -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO (IO(IO)) -#else -import GHC.IOBase (IO(IO),RawBuffer) -#endif -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO (unsafeDupablePerformIO) -#else -import GHC.IOBase (unsafeDupablePerformIO) -#endif -#else -import Data.Char (chr) -import System.IO.Unsafe (unsafePerformIO) -#endif - -#ifdef __GLASGOW_HASKELL__ -import GHC.ForeignPtr (mallocPlainForeignPtrBytes) -#else -import Foreign.ForeignPtr (mallocForeignPtrBytes) -#endif - -#ifdef __GLASGOW_HASKELL__ -import GHC.ForeignPtr (ForeignPtr(ForeignPtr)) -import GHC.Base (nullAddr#) -#else -import Foreign.Ptr (nullPtr) -#endif - -#if __HUGS__ -import Hugs.ForeignPtr (newForeignPtr_) -#elif __GLASGOW_HASKELL__<=604 -import Foreign.ForeignPtr (newForeignPtr_) -#endif - --- CFILES stuff is Hugs only -{-# CFILES cbits/fpstring.c #-} - --- An alternative to Control.Exception (assert) for nhc98 -#ifdef __NHC__ -#define assert assertS "__FILE__ : __LINE__" -assertS :: String -> Bool -> a -> a -assertS _ True = id -assertS s False = error ("assertion failed at "++s) -#endif - --- ----------------------------------------------------------------------------- --- --- Useful macros, until we have bang patterns --- - -#define STRICT1(f) f a | a `seq` False = undefined -#define STRICT2(f) f a b | a `seq` b `seq` False = undefined -#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined -#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined -#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined - --- ----------------------------------------------------------------------------- - --- | A space-efficient representation of a Word8 vector, supporting many --- efficient operations. A 'ByteString' contains 8-bit characters only. --- --- Instances of Eq, Ord, Read, Show, Data, Typeable --- -data ByteString = PS {-# UNPACK #-} !(ForeignPtr Word8) -- payload - {-# UNPACK #-} !Int -- offset - {-# UNPACK #-} !Int -- length - -#if defined(__GLASGOW_HASKELL__) - deriving (Typeable) -#endif - -instance Eq ByteString where - (==) = eq - -instance Ord ByteString where - compare = compareBytes - -instance Monoid ByteString where - mempty = PS nullForeignPtr 0 0 - mappend = append - mconcat = concat - -instance NFData ByteString - -instance Show ByteString where - showsPrec p ps r = showsPrec p (unpackChars ps) r - -instance Read ByteString where - readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ] - -#if MIN_VERSION_base(3,0,0) -instance IsString ByteString where - fromString = packChars -#endif - -instance Data ByteString where - gfoldl f z txt = z packBytes `f` (unpackBytes txt) - toConstr _ = error "Data.ByteString.ByteString.toConstr" - gunfold _ _ = error "Data.ByteString.ByteString.gunfold" -#if MIN_VERSION_base(4,2,0) - dataTypeOf _ = mkNoRepType "Data.ByteString.ByteString" -#else - dataTypeOf _ = mkNorepType "Data.ByteString.ByteString" -#endif - ------------------------------------------------------------------------- --- Packing and unpacking from lists - -packBytes :: [Word8] -> ByteString -packBytes ws = unsafePackLenBytes (List.length ws) ws - -packChars :: [Char] -> ByteString -packChars cs = unsafePackLenChars (List.length cs) cs - -unsafePackLenBytes :: Int -> [Word8] -> ByteString -unsafePackLenBytes len xs0 = - unsafeCreate len $ \p -> go p xs0 - where - go !_ [] = return () - go !p (x:xs) = poke p x >> go (p `plusPtr` 1) xs - -unsafePackLenChars :: Int -> [Char] -> ByteString -unsafePackLenChars len cs0 = - unsafeCreate len $ \p -> go p cs0 - where - go !_ [] = return () - go !p (c:cs) = poke p (c2w c) >> go (p `plusPtr` 1) cs - -packUptoLenBytes :: Int -> [Word8] -> (ByteString, [Word8]) -packUptoLenBytes len xs0 = - unsafeDupablePerformIO $ create' len $ \p -> go p len xs0 - where - go !_ !n [] = return (len-n, []) - go !_ !0 xs = return (len, xs) - go !p !n (x:xs) = poke p x >> go (p `plusPtr` 1) (n-1) xs - -packUptoLenChars :: Int -> [Char] -> (ByteString, [Char]) -packUptoLenChars len cs0 = - unsafeDupablePerformIO $ create' len $ \p -> go p len cs0 - where - go !_ !n [] = return (len-n, []) - go !_ !0 cs = return (len, cs) - go !p !n (c:cs) = poke p (c2w c) >> go (p `plusPtr` 1) (n-1) cs - --- Unpacking bytestrings into lists effeciently is a tradeoff: on the one hand --- we would like to write a tight loop that just blats the list into memory, on --- the other hand we want it to be unpacked lazily so we don't end up with a --- massive list data structure in memory. --- --- Our strategy is to combine both: we will unpack lazily in reasonable sized --- chunks, where each chunk is unpacked strictly. --- --- unpackBytes and unpackChars do the lazy loop, while unpackAppendBytes and --- unpackAppendChars do the chunks strictly. - -unpackBytes :: ByteString -> [Word8] -unpackBytes bs = unpackAppendBytesLazy bs [] - -unpackChars :: ByteString -> [Char] -unpackChars bs = unpackAppendCharsLazy bs [] - -unpackAppendBytesLazy :: ByteString -> [Word8] -> [Word8] -unpackAppendBytesLazy (PS fp off len) xs - | len <= 100 = unpackAppendBytesStrict (PS fp off len) xs - | otherwise = unpackAppendBytesStrict (PS fp off 100) remainder - where - remainder = unpackAppendBytesLazy (PS fp (off+100) (len-100)) xs - - -- Why 100 bytes you ask? Because on a 64bit machine the list we allocate - -- takes just shy of 4k which seems like a reasonable amount. - -- (5 words per list element, 8 bytes per word, 100 elements = 4000 bytes) - -unpackAppendCharsLazy :: ByteString -> [Char] -> [Char] -unpackAppendCharsLazy (PS fp off len) cs - | len <= 100 = unpackAppendCharsStrict (PS fp off len) cs - | otherwise = unpackAppendCharsStrict (PS fp off 100) remainder - where - remainder = unpackAppendCharsLazy (PS fp (off+100) (len-100)) cs - --- For these unpack functions, since we're unpacking the whole list strictly we --- build up the result list in an accumulator. This means we have to build up --- the list starting at the end. So our traversal starts at the end of the --- buffer and loops down until we hit the sentinal: - -unpackAppendBytesStrict :: ByteString -> [Word8] -> [Word8] -unpackAppendBytesStrict (PS fp off len) xs = - inlinePerformIO $ withForeignPtr fp $ \base -> do - loop (base `plusPtr` (off-1)) (base `plusPtr` (off-1+len)) xs - where - loop !sentinal !p acc - | p == sentinal = return acc - | otherwise = do x <- peek p - loop sentinal (p `plusPtr` (-1)) (x:acc) - -unpackAppendCharsStrict :: ByteString -> [Char] -> [Char] -unpackAppendCharsStrict (PS fp off len) xs = - inlinePerformIO $ withForeignPtr fp $ \base -> - loop (base `plusPtr` (off-1)) (base `plusPtr` (off-1+len)) xs - where - loop !sentinal !p acc - | p == sentinal = return acc - | otherwise = do x <- peek p - loop sentinal (p `plusPtr` (-1)) (w2c x:acc) - ------------------------------------------------------------------------- - --- | The 0 pointer. Used to indicate the empty Bytestring. -nullForeignPtr :: ForeignPtr Word8 -#ifdef __GLASGOW_HASKELL__ -nullForeignPtr = ForeignPtr nullAddr# (error "nullForeignPtr") --TODO: should ForeignPtrContents be strict? -#else -nullForeignPtr = unsafePerformIO $ newForeignPtr_ nullPtr -{-# NOINLINE nullForeignPtr #-} -#endif - --- --------------------------------------------------------------------- --- Low level constructors - --- | /O(1)/ Build a ByteString from a ForeignPtr. --- --- If you do not need the offset parameter then you do should be using --- 'Data.ByteString.Unsafe.unsafePackCStringLen' or --- 'Data.ByteString.Unsafe.unsafePackCStringFinalizer' instead. --- -fromForeignPtr :: ForeignPtr Word8 - -> Int -- ^ Offset - -> Int -- ^ Length - -> ByteString -fromForeignPtr fp s l = PS fp s l -{-# INLINE fromForeignPtr #-} - --- | /O(1)/ Deconstruct a ForeignPtr from a ByteString -toForeignPtr :: ByteString -> (ForeignPtr Word8, Int, Int) -- ^ (ptr, offset, length) -toForeignPtr (PS ps s l) = (ps, s, l) -{-# INLINE toForeignPtr #-} - --- | A way of creating ByteStrings outside the IO monad. The @Int@ --- argument gives the final size of the ByteString. Unlike --- 'createAndTrim' the ByteString is not reallocated if the final size --- is less than the estimated size. -unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> ByteString -unsafeCreate l f = unsafeDupablePerformIO (create l f) -{-# INLINE unsafeCreate #-} - -#ifndef __GLASGOW_HASKELL__ --- for Hugs, NHC etc -unsafeDupablePerformIO :: IO a -> a -unsafeDupablePerformIO = unsafePerformIO -#endif - --- | Create ByteString of size @l@ and use action @f@ to fill it's contents. -create :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString -create l f = do - fp <- mallocByteString l - withForeignPtr fp $ \p -> f p - return $! PS fp 0 l -{-# INLINE create #-} - --- | Create ByteString of up to size @l@ and use action @f@ to fill it's contents which returns its true size. -create' :: Int -> (Ptr Word8 -> IO (Int, a)) -> IO (ByteString, a) -create' l f = do - fp <- mallocByteString l - (l', res) <- withForeignPtr fp $ \p -> f p - assert (l' <= l) $ return (PS fp 0 l', res) -{-# INLINE create' #-} - --- | Given the maximum size needed and a function to make the contents --- of a ByteString, createAndTrim makes the 'ByteString'. The generating --- function is required to return the actual final size (<= the maximum --- size), and the resulting byte array is realloced to this size. --- --- createAndTrim is the main mechanism for creating custom, efficient --- ByteString functions, using Haskell or C functions to fill the space. --- -createAndTrim :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString -createAndTrim l f = do - fp <- mallocByteString l - withForeignPtr fp $ \p -> do - l' <- f p - if assert (l' <= l) $ l' >= l - then return $! PS fp 0 l - else create l' $ \p' -> memcpy p' p l' -{-# INLINE createAndTrim #-} - -createAndTrim' :: Int -> (Ptr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a) -createAndTrim' l f = do - fp <- mallocByteString l - withForeignPtr fp $ \p -> do - (off, l', res) <- f p - if assert (l' <= l) $ l' >= l - then return $! (PS fp 0 l, res) - else do ps <- create l' $ \p' -> - memcpy p' (p `plusPtr` off) l' - return $! (ps, res) - --- | Wrapper of 'mallocForeignPtrBytes' with faster implementation for GHC --- -mallocByteString :: Int -> IO (ForeignPtr a) -mallocByteString l = do -#ifdef __GLASGOW_HASKELL__ - mallocPlainForeignPtrBytes l -#else - mallocForeignPtrBytes l -#endif -{-# INLINE mallocByteString #-} - ------------------------------------------------------------------------- --- Implementations for Eq, Ord and Monoid instances - -eq :: ByteString -> ByteString -> Bool -eq a@(PS fp off len) b@(PS fp' off' len') - | len /= len' = False -- short cut on length - | fp == fp' && off == off' = True -- short cut for the same string - | otherwise = compareBytes a b == EQ -{-# INLINE eq #-} --- ^ still needed - -compareBytes :: ByteString -> ByteString -> Ordering -compareBytes (PS _ _ 0) (PS _ _ 0) = EQ -- short cut for empty strings -compareBytes (PS fp1 off1 len1) (PS fp2 off2 len2) = - inlinePerformIO $ - withForeignPtr fp1 $ \p1 -> - withForeignPtr fp2 $ \p2 -> do - i <- memcmp (p1 `plusPtr` off1) (p2 `plusPtr` off2) (min len1 len2) - return $! case i `compare` 0 of - EQ -> len1 `compare` len2 - x -> x - -append :: ByteString -> ByteString -> ByteString -append (PS _ _ 0) b = b -append a (PS _ _ 0) = a -append (PS fp1 off1 len1) (PS fp2 off2 len2) = - unsafeCreate (len1+len2) $ \destptr1 -> do - let destptr2 = destptr1 `plusPtr` len1 - withForeignPtr fp1 $ \p1 -> memcpy destptr1 (p1 `plusPtr` off1) len1 - withForeignPtr fp2 $ \p2 -> memcpy destptr2 (p2 `plusPtr` off2) len2 - -concat :: [ByteString] -> ByteString -concat [] = mempty -concat [bs] = bs -concat bss0 = unsafeCreate totalLen $ \ptr -> go bss0 ptr - where - totalLen = List.sum [ len | (PS _ _ len) <- bss0 ] - go [] !_ = return () - go (PS fp off len:bss) !ptr = do - withForeignPtr fp $ \p -> memcpy ptr (p `plusPtr` off) len - go bss (ptr `plusPtr` len) - ------------------------------------------------------------------------- - --- | Conversion between 'Word8' and 'Char'. Should compile to a no-op. -w2c :: Word8 -> Char -#if !defined(__GLASGOW_HASKELL__) -w2c = chr . fromIntegral -#else -w2c = unsafeChr . fromIntegral -#endif -{-# INLINE w2c #-} - --- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and --- silently truncates to 8 bits Chars > '\255'. It is provided as --- convenience for ByteString construction. -c2w :: Char -> Word8 -c2w = fromIntegral . ord -{-# INLINE c2w #-} - --- | Selects words corresponding to white-space characters in the Latin-1 range --- ordered by frequency. -isSpaceWord8 :: Word8 -> Bool -isSpaceWord8 w = - w == 0x20 || - w == 0x0A || -- LF, \n - w == 0x09 || -- HT, \t - w == 0x0C || -- FF, \f - w == 0x0D || -- CR, \r - w == 0x0B || -- VT, \v - w == 0xA0 -- spotted by QC.. -{-# INLINE isSpaceWord8 #-} - --- | Selects white-space characters in the Latin-1 range -isSpaceChar8 :: Char -> Bool -isSpaceChar8 c = - c == ' ' || - c == '\t' || - c == '\n' || - c == '\r' || - c == '\f' || - c == '\v' || - c == '\xa0' -{-# INLINE isSpaceChar8 #-} - ------------------------------------------------------------------------- - --- | Just like unsafePerformIO, but we inline it. Big performance gains as --- it exposes lots of things to further inlining. /Very unsafe/. In --- particular, you should do no memory allocation inside an --- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@. --- -{-# INLINE inlinePerformIO #-} -inlinePerformIO :: IO a -> a -#if defined(__GLASGOW_HASKELL__) -inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r -#else -inlinePerformIO = unsafePerformIO -#endif - --- --------------------------------------------------------------------- --- --- Standard C functions --- - -foreign import ccall unsafe "string.h strlen" c_strlen - :: CString -> IO CSize - -foreign import ccall unsafe "static stdlib.h &free" c_free_finalizer - :: FunPtr (Ptr Word8 -> IO ()) - -foreign import ccall unsafe "string.h memchr" c_memchr - :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8) - -memchr :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8) -memchr p w s = c_memchr p (fromIntegral w) s - -foreign import ccall unsafe "string.h memcmp" c_memcmp - :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt - -memcmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO CInt -memcmp p q s = c_memcmp p q (fromIntegral s) - -foreign import ccall unsafe "string.h memcpy" c_memcpy - :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8) - -memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () -memcpy p q s = c_memcpy p q (fromIntegral s) >> return () - -{- -foreign import ccall unsafe "string.h memmove" c_memmove - :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8) - -memmove :: Ptr Word8 -> Ptr Word8 -> CSize -> IO () -memmove p q s = do c_memmove p q s - return () --} - -foreign import ccall unsafe "string.h memset" c_memset - :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8) - -memset :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8) -memset p w s = c_memset p (fromIntegral w) s - --- --------------------------------------------------------------------- --- --- Uses our C code --- - -foreign import ccall unsafe "static fpstring.h fps_reverse" c_reverse - :: Ptr Word8 -> Ptr Word8 -> CULong -> IO () - -foreign import ccall unsafe "static fpstring.h fps_intersperse" c_intersperse - :: Ptr Word8 -> Ptr Word8 -> CULong -> Word8 -> IO () - -foreign import ccall unsafe "static fpstring.h fps_maximum" c_maximum - :: Ptr Word8 -> CULong -> IO Word8 + w2c, c2w, isSpaceWord8, isSpaceChar8, -foreign import ccall unsafe "static fpstring.h fps_minimum" c_minimum - :: Ptr Word8 -> CULong -> IO Word8 + -- * Deprecated and unmentionable + accursedUnutterablePerformIO, -foreign import ccall unsafe "static fpstring.h fps_count" c_count - :: Ptr Word8 -> CULong -> Word8 -> IO CULong + -- * Exported compatibility shim + plusForeignPtr, + unsafeWithForeignPtr + ) where +import Data.ByteString.Internal.Type diff --git a/Data/ByteString/Internal/Pure.hs b/Data/ByteString/Internal/Pure.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Internal/Pure.hs @@ -0,0 +1,418 @@ +-- Enable yields to make `isValidUtf8` safe to use on large inputs. +{-# OPTIONS_GHC -fno-omit-yields #-} + +-- | Haskell implementation of C bits +module Data.ByteString.Internal.Pure + ( -- * standard string.h functions + strlen + , memchr + , memcmp + -- * fpstring.c + , intersperse + , countOcc + , countOccBA + , reverseBytes + , findMaximum + , findMinimum + , quickSort + , elemIndex + , isValidUtf8 + , isValidUtf8BA + -- * itoa.c + , encodeSignedDec + , encodeUnsignedDec + , encodeUnsignedDecPadded + , encodeUnsignedHex + -- * static tables (unaligned!) + , lower_hex_table + , digit_pairs_table + ) +where + +import Prelude + +import GHC.Exts (Ptr(..), ByteArray#, indexWord8Array#, Word8#, Int#, indexWord8OffAddr#) +import GHC.Types (Int (..)) +import GHC.Word (Word8(..)) +import GHC.Int (Int8(..)) + +import Data.Bits (Bits(..), shiftR, (.&.)) +import Data.Word +import Foreign.Ptr (plusPtr, nullPtr) +import Foreign.Storable (Storable(..)) +import Control.Monad (when) +import Control.Exception (assert) + +import Data.ByteString.Utils.ByteOrder +import Data.ByteString.Utils.UnalignedAccess + +---------------------------------------------------------------- +-- Haskell versions of standard functions in string.h +---------------------------------------------------------------- + +strlen :: Ptr Word8 -> IO Int +strlen = go 0 where + go :: Int -> Ptr Word8 -> IO Int + go !acc !p = do + c <- peek p + if | c == 0 -> pure acc + | nextAcc <- acc + 1 + , nextAcc >= 0 -> go nextAcc (p `plusPtr` 1) + | otherwise -> errorWithoutStackTrace + "bytestring: strlen: String length does not fit in a Haskell Int" + +memchr :: Ptr Word8 -> Word8 -> Int -> IO (Ptr Word8) +memchr !p !target !len + | len == 0 = pure nullPtr + | otherwise = assert (len > 0) $ do + c <- peek p + if c == target + then pure p + else memchr (p `plusPtr` 1) target (len - 1) + +memcmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO Int +memcmp !p1 !p2 !len + | len >= 8 = do + w1 <- unalignedReadU64 p1 + w2 <- unalignedReadU64 p2 + let toBigEndian = whenLittleEndian byteSwap64 + if | w1 == w2 + -> memcmp (p1 `plusPtr` 8) (p2 `plusPtr` 8) (len - 8) + | toBigEndian w1 < toBigEndian w2 + -> pure (0-1) + | otherwise -> pure 1 + | otherwise = memcmp1 p1 p2 len + +-- | Like 'memcmp', but definitely scans one byte at a time +memcmp1 :: Ptr Word8 -> Ptr Word8 -> Int -> IO Int +memcmp1 !p1 !p2 !len + | len == 0 = pure 0 + | otherwise = assert (len > 0) $ do + c1 <- peek p1 + c2 <- peek p2 + if | c1 == c2 -> memcmp1 (p1 `plusPtr` 1) (p2 `plusPtr` 1) (len - 1) + | c1 < c2 -> pure (0-1) + | otherwise -> pure 1 + + +---------------------------------------------------------------- +-- Haskell versions of functions in fpstring.c +---------------------------------------------------------------- + +-- | duplicate a string, interspersing the character through the elements of the +-- duplicated string +intersperse :: Ptr Word8 -> Ptr Word8 -> Int -> Word8 -> IO () +intersperse !dst !src !len !w = case len of + 0 -> pure () + 1 -> do + -- copy last char + c <- peekByteOff src 0 + pokeByteOff dst 0 (c :: Word8) + _ -> do + c <- peekByteOff src 0 + pokeByteOff dst 0 (c :: Word8) + pokeByteOff dst 1 w + intersperse (plusPtr dst 2) (plusPtr src 1) (len-1) w + +countOccBA :: ByteArray# -> Int -> Word8 -> IO Int +countOccBA ba len w = pure (go 0 0) + where + go !n !i@(I# i#) + | i == len = n + | W8# (indexWord8Array# ba i#) == w = go (n+1) (i+1) + | otherwise = go n (i+1) + +countOcc :: Ptr Word8 -> Int -> Word8 -> IO Int +countOcc p len w = go 0 0 + where + go !n !i + | i == len = pure n + | otherwise = do + c <- peekByteOff p i + if c == w + then go (n+1) (i+1) + else go n (i+1) + +-- | Haskell equivalent of C `sbs_elem_index` +elemIndex :: ByteArray# -> Word8 -> Int -> IO Int +elemIndex !ba !w !len = pure (go 0) + where + go !i@(I# i#) + | i == len = -1 + | W8# (indexWord8Array# ba i#) == w = i + | otherwise = go (i+1) + +-- | Reverse n-bytes from the second pointer into the first +reverseBytes :: Ptr Word8 -> Ptr Word8 -> Int -> IO () +reverseBytes !dst !src !n + | n == 0 = pure () + | otherwise = reverse_bytes dst (plusPtr dst (n - 1)) src + +-- | Note that reverse_bytes reverses at least one byte. +-- Then it loops if necessary until the destination buffer is full +reverse_bytes :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO () +reverse_bytes orig_dst dst src = do + c <- peekByteOff src 0 + pokeByteOff dst 0 (c :: Word8) + if orig_dst == dst + then pure () + else reverse_bytes orig_dst (plusPtr dst (-1)) (plusPtr src 1) + + +findMaximum :: Ptr Word8 -> Int -> IO Word8 +findMaximum !p !n = assert (n > 0) $ find_maximum minBound p (plusPtr p (n - 1)) + +find_maximum :: Word8 -> Ptr Word8 -> Ptr Word8 -> IO Word8 +find_maximum !m !p !plast = do + c <- peekByteOff p 0 + let !c' = if c > m then c else m + if p == plast + then pure c' + else find_maximum c' (plusPtr p 1) plast + +findMinimum :: Ptr Word8 -> Int -> IO Word8 +findMinimum !p !n = assert (n > 0) $ find_minimum maxBound p (plusPtr p (n - 1)) + +find_minimum :: Word8 -> Ptr Word8 -> Ptr Word8 -> IO Word8 +find_minimum !m !p !plast = do + c <- peekByteOff p 0 + let !c' = if c < m then c else m + if p == plast + then pure c' + else find_minimum c' (plusPtr p 1) plast + + +quickSort :: Ptr Word8 -> Int -> IO () +quickSort !p !n + | n <= 0 = pure () + | otherwise = quick_sort p 0 (n - 1) + +quick_sort :: Ptr Word8 -> Int -> Int -> IO () +quick_sort !p !low !high + | low >= high = pure () + | otherwise = do + pivot_index <- partition p low high + quick_sort p low (pivot_index-1) + quick_sort p (pivot_index+1) high + + +partition :: Ptr Word8 -> Int -> Int -> IO Int +partition !p !low !high = do + -- choose the rightmost element as the pivot + pivot <- peekByteOff p high :: IO Word8 + -- traverse through all elements. + -- swap element smaller than pivot at index j with leftmost element at + -- index i greater than pivot (can be itself if no greater element read yet) + let go !i !j + | j > high = pure (i-1) + | otherwise = do + jv <- peekByteOff p j + if (jv <= pivot) + then do + when (i /= j) $ do + -- swap values + iv <- peekByteOff p i :: IO Word8 + pokeByteOff p j iv + pokeByteOff p i jv + go (i+1) (j+1) + else + go i (j+1) + go low low + +isValidUtf8BA :: ByteArray# -> Int -> IO Bool +isValidUtf8BA !ba !len' = isValidUtf8' (indexWord8Array# ba) len' + +isValidUtf8 :: Ptr Word8 -> Int -> IO Bool +isValidUtf8 !(Ptr a) !len' = isValidUtf8' (indexWord8OffAddr# a) len' + +isValidUtf8' :: (Int# -> Word8#) -> Int -> IO Bool +isValidUtf8' idx !len = go 0 + where + indexWord8 (I# i) = W8# (idx i) + + indexIsCont :: Int -> Bool + indexIsCont i = + -- We use a signed comparison to avoid an extra comparison with 0x80, + -- since _signed_ 0x80 is -128. + let + v :: Int8 + v = fromIntegral (indexWord8 i) + in v <= (fromIntegral (0xBF :: Word8)) + + go !i + | i >= len = pure True -- done + | otherwise = do + let !b0 = indexWord8 i + if | b0 <= 0x7F -> go (i+1) -- ASCII + | b0 >= 0xC2 && b0 <= 0xDF -> go2 (i+1) + | b0 >= 0xE0 && b0 <= 0xEF -> go3 (i+1) b0 + | otherwise -> go4 (i+1) b0 + + go2 !i + | i >= len = pure False + | indexIsCont i + = go (i+1) + | otherwise + = pure False + + go3 !i !b0 + | i >= len - 1 = pure False -- Be careful: i+1 might overflow! + | indexIsCont i + , indexIsCont (i+1) + , b1 <- indexWord8 i + , (b0 == 0xE0 && b1 >= 0xA0) -- E0, A0..BF, 80..BF + || (b0 >= 0xE1 && b0 <= 0xEC) -- E1..EC, 80..BF, 80..BF + || (b0 == 0xED && b1 <= 0x9F) -- ED, 80..9F, 80..BF + || (b0 >= 0xEE && b0 <= 0xEF) -- EE..EF, 80..BF, 80..BF + = go (i+2) + | otherwise + = pure False + + go4 !i !b0 + | i >= len - 2 = pure False -- Be careful: i+2 might overflow! + | indexIsCont i + , indexIsCont (i+1) + , indexIsCont (i+2) + , b1 <- indexWord8 i + , (b0 == 0xF0 && b1 >= 0x90) -- F0, 90..BF, 80..BF, 80..BF + || (b0 >= 0xF1 && b0 <= 0xF3) -- F1..F3, 80..BF, 80..BF, 80..BF + || (b0 == 0xF4 && b1 <= 0x8F) -- F4, 80..8F, 80..BF, 80..BF + = go (i+3) + + | otherwise + = pure False + + +---------------------------------------------------------------- +-- Haskell versions of functions in itoa.c +---------------------------------------------------------------- + + +getDigit :: Int -> Word8 +getDigit (I# i) = W8# (indexWord8OffAddr# digits i) + where + !digits = "0123456789abcdef"# + +putDigit :: Ptr a -> Int -> Int -> IO () +putDigit !addr !off !i = pokeByteOff addr off (getDigit i) + +-- | Reverse bytes in the given memory range (inclusive) +reverseBytesInplace :: Ptr Word8 -> Ptr Word8 -> IO () +reverseBytesInplace !p1 !p2 + | p1 < p2 = do + c1 <- peekByteOff p1 0 + c2 <- peekByteOff p2 0 + pokeByteOff p1 0 (c2 :: Word8) + pokeByteOff p2 0 (c1 :: Word8) + reverseBytesInplace (plusPtr p1 1) (plusPtr p2 (-1)) + | otherwise = pure () + +-- | Encode signed number as decimal +encodeSignedDec :: (Eq a, Num a, Integral a) => a -> Ptr Word8 -> IO (Ptr Word8) +{-# INLINABLE encodeSignedDec #-} -- for specialization +encodeSignedDec !x !buf + | x >= 0 = encodeUnsignedDec x buf + | otherwise = do + -- we cannot negate directly as 0 - (minBound :: Int) = minBound + -- So we write the sign and the first digit. + pokeByteOff buf 0 '-' + let !(q,r) = quotRem x (-10) + putDigit buf 1 (fromIntegral (abs r)) + case q of + 0 -> pure (plusPtr buf 2) + _ -> encodeUnsignedDec' q (plusPtr buf 1) (plusPtr buf 2) + + +-- | Encode positive number as decimal +encodeUnsignedDec :: (Eq a, Num a, Integral a) => a -> Ptr Word8 -> IO (Ptr Word8) +{-# INLINABLE encodeUnsignedDec #-} -- for specialization +encodeUnsignedDec !v !next_ptr = encodeUnsignedDec' v next_ptr next_ptr + +-- | Encode positive number as little-endian decimal, then reverse it. +-- +-- Take two pointers (orig_ptr, next_ptr) to support already encoded digits +-- (e.g. used by encodeSignedDec to avoid overflows) +-- +encodeUnsignedDec' :: (Eq a, Num a, Integral a) => a -> Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8) +{-# INLINABLE encodeUnsignedDec' #-} -- for specialization +encodeUnsignedDec' !v !orig_ptr !next_ptr = do + let !(q,r) = divMod v 10 + putDigit next_ptr 0 (fromIntegral r) + case q of + 0 -> do + -- reverse written digits + reverseBytesInplace orig_ptr next_ptr + -- return pointer after our digits + pure (plusPtr next_ptr 1) + _ -> encodeUnsignedDec' q orig_ptr (plusPtr next_ptr 1) + +encodeUnsignedDecPadded :: (Eq a, Num a, Integral a) => Int -> a -> Ptr Word8 -> IO () +{-# INLINABLE encodeUnsignedDecPadded #-} -- for specialization +encodeUnsignedDecPadded !max_width !v !buf = assert (max_width > 0) $ do + let !(q,r) = divMod v 10 + putDigit buf (max_width - 1) (fromIntegral r) + case q of + 0 -> do + -- pad beginning + let pad 0 = pure () + pad n = putDigit buf (n - 1) 0 >> pad (n - 1) + pad (max_width - 1) + _ -> encodeUnsignedDecPadded (max_width - 1) q buf + + + +-- | Encode positive number as hexadecimal +encodeUnsignedHex :: (Eq a, Num a, Integral a, Bits a) => a -> Ptr Word8 -> IO (Ptr Word8) +{-# INLINABLE encodeUnsignedHex #-} -- for specialization +encodeUnsignedHex !v !next_ptr = encodeUnsignedHex' v next_ptr next_ptr + +-- | Encode positive number as little-endian hexdecimal, then reverse it. +-- +-- Take two pointers (orig_ptr, next_ptr) to support already encoded digits +encodeUnsignedHex' :: (Eq a, Num a, Integral a, Bits a) => a -> Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8) +{-# INLINABLE encodeUnsignedHex' #-} -- for specialization +encodeUnsignedHex' !v !orig_ptr !next_ptr = do + -- (q,r) = divMod v 16, but faster + let !q = v `shiftR` 4 + let !r = v .&. 0x0F + putDigit next_ptr 0 (fromIntegral r) + case q of + 0 -> do + -- reverse written digits + reverseBytesInplace orig_ptr next_ptr + -- return pointer after our digits + pure (plusPtr next_ptr 1) + _ -> encodeUnsignedHex' q orig_ptr (plusPtr next_ptr 1) + + +lower_hex_table :: Ptr Word16 +lower_hex_table = Ptr + "000102030405060708090a0b0c0d0e0f\ + \101112131415161718191a1b1c1d1e1f\ + \202122232425262728292a2b2c2d2e2f\ + \303132333435363738393a3b3c3d3e3f\ + \404142434445464748494a4b4c4d4e4f\ + \505152535455565758595a5b5c5d5e5f\ + \606162636465666768696a6b6c6d6e6f\ + \707172737475767778797a7b7c7d7e7f\ + \808182838485868788898a8b8c8d8e8f\ + \909192939495969798999a9b9c9d9e9f\ + \a0a1a2a3a4a5a6a7a8a9aaabacadaeaf\ + \b0b1b2b3b4b5b6b7b8b9babbbcbdbebf\ + \c0c1c2c3c4c5c6c7c8c9cacbcccdcecf\ + \d0d1d2d3d4d5d6d7d8d9dadbdcdddedf\ + \e0e1e2e3e4e5e6e7e8e9eaebecedeeef\ + \f0f1f2f3f4f5f6f7f8f9fafbfcfdfeff"# + +digit_pairs_table :: Ptr Word16 +digit_pairs_table = Ptr + "00010203040506070809\ + \10111213141516171819\ + \20212223242526272829\ + \30313233343536373839\ + \40414243444546474849\ + \50515253545556575859\ + \60616263646566676869\ + \70717273747576777879\ + \80818283848586878889\ + \90919293949596979899"# diff --git a/Data/ByteString/Internal/Type.hs b/Data/ByteString/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Internal/Type.hs @@ -0,0 +1,1298 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Unsafe #-} + +{-# OPTIONS_HADDOCK not-home #-} + +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE ViewPatterns #-} + +#include "bytestring-cpp-macros.h" + +-- | +-- Module : Data.ByteString.Internal.Type +-- Copyright : (c) Don Stewart 2006-2008 +-- (c) Duncan Coutts 2006-2012 +-- License : BSD-style +-- Maintainer : dons00@gmail.com, duncan@community.haskell.org +-- Stability : unstable +-- Portability : non-portable +-- +-- The 'ByteString' type, its instances, and whatever related +-- utilities the bytestring developers see fit to use internally. +-- +module Data.ByteString.Internal.Type ( + + -- * The @ByteString@ type and representation + ByteString + ( BS + , PS -- backwards compatibility shim + ), + + StrictByteString, + + -- * Internal indexing + findIndexOrLength, + + -- * Conversion with lists: packing and unpacking + packBytes, packUptoLenBytes, unsafePackLenBytes, + packChars, packUptoLenChars, unsafePackLenChars, + unpackBytes, unpackAppendBytesLazy, unpackAppendBytesStrict, + unpackChars, unpackAppendCharsLazy, unpackAppendCharsStrict, + unsafePackAddress, unsafePackLenAddress, + unsafePackLiteral, unsafePackLenLiteral, + + -- * Low level imperative construction + empty, + createFp, + createFpUptoN, + createFpUptoN', + createFpAndTrim, + createFpAndTrim', + unsafeCreateFp, + unsafeCreateFpUptoN, + unsafeCreateFpUptoN', + create, + createUptoN, + createUptoN', + createAndTrim, + createAndTrim', + unsafeCreate, + unsafeCreateUptoN, + unsafeCreateUptoN', + mallocByteString, + + -- * Conversion to and from ForeignPtrs + mkDeferredByteString, + fromForeignPtr, + toForeignPtr, + fromForeignPtr0, + toForeignPtr0, + + -- * Utilities + nullForeignPtr, + peekFp, + pokeFp, + peekFpByteOff, + pokeFpByteOff, + minusForeignPtr, + memcpyFp, + deferForeignPtrAvailability, + unsafeDupablePerformIO, + SizeOverflowException, + overflowError, + checkedAdd, + checkedMultiply, + + -- * Standard C Functions + c_strlen, + c_free_finalizer, + + memchr, + memcmp, + memcpy, + memset, + + -- * cbits functions + c_reverse, + c_intersperse, + c_maximum, + c_minimum, + c_count, + c_count_ba, + c_elem_index, + c_sort, + c_int_dec, + c_int_dec_padded9, + c_uint_dec, + c_uint_hex, + c_long_long_int_dec, + c_long_long_int_dec_padded18, + c_long_long_uint_dec, + c_long_long_uint_hex, + cIsValidUtf8BA, + cIsValidUtf8BASafe, + cIsValidUtf8, + cIsValidUtf8Safe, + + -- * Chars + w2c, c2w, isSpaceWord8, isSpaceChar8, + + -- * Deprecated and unmentionable + accursedUnutterablePerformIO, + + -- * Exported compatibility shim + plusForeignPtr, + unsafeWithForeignPtr + ) where + +import Prelude hiding (concat, null) +import qualified Data.List as List + +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr +import Foreign.Storable (Storable(..)) +import Foreign.C.Types +import Foreign.C.String (CString) +import Foreign.Marshal.Utils +import Foreign.Marshal.Alloc (finalizerFree) + +#if PURE_HASKELL +import qualified Data.ByteString.Internal.Pure as Pure +import Data.Bits (toIntegralSized, Bits) +import Data.Maybe (fromMaybe) +import Control.Monad ((<$!>)) +#endif + +import Data.Semigroup (Semigroup (..)) +import Data.List.NonEmpty (NonEmpty ((:|))) + +import Control.DeepSeq (NFData(rnf)) + +import Data.String (IsString(..)) + +import Control.Exception (assert, throw, Exception) + +import Data.Bits ((.&.)) +import Data.Char (ord) +import Data.Word + +import Data.Data (Data(..), mkConstr, mkNoRepType, Constr, DataType, Fixity(Prefix), constrIndex) + +import GHC.Base (nullAddr#,realWorld#,unsafeChr,unpackCString#) +import GHC.Exts (IsList(..), Addr#, minusAddr#, ByteArray#, runRW#, lazy) + +#if HS_timesInt2_PRIMOP_AVAILABLE +import GHC.Exts (timesInt2#) +#else +import GHC.Exts ( timesWord2# + , or# + , uncheckedShiftRL# + , int2Word# + , word2Int# + ) +import Data.Bits (finiteBitSize) +#endif + +import GHC.IO (IO(IO)) +import GHC.ForeignPtr (ForeignPtr(ForeignPtr) +#if !HS_cstringLength_AND_FinalPtr_AVAILABLE + , newForeignPtr_ +#endif + , mallocPlainForeignPtrBytes) + +import GHC.ForeignPtr (plusForeignPtr) + +#if HS_cstringLength_AND_FinalPtr_AVAILABLE +import GHC.Exts (cstringLength#) +import GHC.ForeignPtr (ForeignPtrContents(FinalPtr)) +#else +import GHC.Ptr (Ptr(..)) +#endif + +import GHC.Int (Int (..)) + +#if HS_unsafeWithForeignPtr_AVAILABLE +import GHC.ForeignPtr (unsafeWithForeignPtr) +#endif + +import qualified Language.Haskell.TH.Lib as TH +import qualified Language.Haskell.TH.Syntax as TH + +#if !HS_unsafeWithForeignPtr_AVAILABLE +unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b +unsafeWithForeignPtr = withForeignPtr +#endif + +-- CFILES stuff is Hugs only +{-# CFILES cbits/fpstring.c #-} + +minusForeignPtr :: ForeignPtr a -> ForeignPtr b -> Int +minusForeignPtr (ForeignPtr addr1 _) (ForeignPtr addr2 _) + = I# (minusAddr# addr1 addr2) + +peekFp :: Storable a => ForeignPtr a -> IO a +peekFp fp = unsafeWithForeignPtr fp peek + +pokeFp :: Storable a => ForeignPtr a -> a -> IO () +pokeFp fp val = unsafeWithForeignPtr fp $ \p -> poke p val + +peekFpByteOff :: Storable a => ForeignPtr a -> Int -> IO a +peekFpByteOff fp off = unsafeWithForeignPtr fp $ \p -> + peekByteOff p off + +pokeFpByteOff :: Storable a => ForeignPtr b -> Int -> a -> IO () +pokeFpByteOff fp off val = unsafeWithForeignPtr fp $ \p -> + pokeByteOff p off val + +-- | Most operations on a 'ByteString' need to read from the buffer +-- given by its @ForeignPtr Word8@ field. But since most operations +-- on @ByteString@ are (nominally) pure, their implementations cannot +-- see the IO state thread that was used to initialize the contents of +-- that buffer. This means that under some circumstances, these +-- buffer-reads may be executed before the writes used to initialize +-- the buffer are executed, with unpredictable results. +-- +-- 'deferForeignPtrAvailability' exists to help solve this problem. +-- At runtime, a call @'deferForeignPtrAvailability' x@ is equivalent +-- to @pure $! x@, but the former is more opaque to the simplifier, so +-- that reads from the pointer in its result cannot be executed until +-- the @'deferForeignPtrAvailability' x@ call is complete. +-- +-- The opaque bits evaporate during CorePrep, so using +-- 'deferForeignPtrAvailability' incurs no direct overhead. +-- +-- @since 0.11.5.0 +deferForeignPtrAvailability :: ForeignPtr a -> IO (ForeignPtr a) +deferForeignPtrAvailability (ForeignPtr addr0# guts) = IO $ \s0 -> + case lazy runRW# (\_ -> (# s0, addr0# #)) of + (# s1, addr1# #) -> (# s1, ForeignPtr addr1# guts #) + +-- | Variant of 'fromForeignPtr0' that calls 'deferForeignPtrAvailability' +-- +-- @since 0.11.5.0 +mkDeferredByteString :: ForeignPtr Word8 -> Int -> IO ByteString +mkDeferredByteString fp len = do + deferredFp <- deferForeignPtrAvailability fp + pure $! BS deferredFp len + +unsafeDupablePerformIO :: IO a -> a +-- Why does this exist? In base-4.15.1.0 until at least base-4.18.0.0, +-- the version of unsafeDupablePerformIO in base prevents unboxing of +-- its results with an opaque call to GHC.Exts.lazy, for reasons described +-- in Note [unsafePerformIO and strictness] in GHC.IO.Unsafe. (See +-- https://hackage.haskell.org/package/base-4.18.0.0/docs/src/GHC.IO.Unsafe.html#line-30 .) +-- Even if we accept the (very questionable) premise that the sort of +-- function described in that note should work, we expect no such +-- calls to be made in the context of bytestring. (And we really want +-- unboxing!) +unsafeDupablePerformIO (IO act) = case runRW# act of (# _, res #) -> res + + + +-- ----------------------------------------------------------------------------- + +-- | A space-efficient representation of a 'Word8' vector, supporting many +-- efficient operations. +-- +-- A 'ByteString' contains 8-bit bytes, or by using the operations from +-- "Data.ByteString.Char8" it can be interpreted as containing 8-bit +-- characters. +-- +data ByteString = BS {-# UNPACK #-} !(ForeignPtr Word8) -- payload + {-# UNPACK #-} !Int -- length + -- ^ @since 0.11.0.0 + +-- | Type synonym for the strict flavour of 'ByteString'. +-- +-- @since 0.11.2.0 +type StrictByteString = ByteString + +-- | +-- @'PS' foreignPtr offset length@ represents a 'ByteString' with data +-- backed by a given @foreignPtr@, starting at a given @offset@ in bytes +-- and of a specified @length@. +-- +-- This pattern is used to emulate the legacy 'ByteString' data +-- constructor, so that pre-existing code generally doesn't need to +-- change to benefit from the simplified 'BS' constructor and can +-- continue to function unchanged. +-- +-- /Note:/ Matching with this constructor will always be given a 0 offset, +-- as the base will be manipulated by 'plusForeignPtr' instead. +-- +pattern PS :: ForeignPtr Word8 -> Int -> Int -> ByteString +pattern PS fp zero len <- BS fp ((0,) -> (zero, len)) where + PS fp o len = BS (plusForeignPtr fp o) len +{-# COMPLETE PS #-} + +instance Eq ByteString where + (==) = eq + +instance Ord ByteString where + compare = compareBytes + +instance Semigroup ByteString where + (<>) = append + sconcat (b:|bs) = concat (b:bs) + {-# INLINE stimes #-} + stimes = stimesPolymorphic + +instance Monoid ByteString where + mempty = empty + mappend = (<>) + mconcat = concat + +instance NFData ByteString where + rnf BS{} = () + +instance Show ByteString where + showsPrec p ps r = showsPrec p (unpackChars ps) r + +instance Read ByteString where + readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ] + +-- | @since 0.10.12.0 +instance IsList ByteString where + type Item ByteString = Word8 + fromList = packBytes + toList = unpackBytes + +-- | Beware: 'fromString' truncates multi-byte characters to octets. +-- e.g. "枯朶に烏のとまりけり秋の暮" becomes �6k�nh~�Q��n� +instance IsString ByteString where + {-# INLINE fromString #-} + fromString = packChars + +instance Data ByteString where + gfoldl f z txt = z packBytes `f` unpackBytes txt + toConstr _ = packConstr + gunfold k z c = case constrIndex c of + 1 -> k (z packBytes) + _ -> error "gunfold: unexpected constructor of strict ByteString" + dataTypeOf _ = byteStringDataType + +packConstr :: Constr +packConstr = mkConstr byteStringDataType "pack" [] Prefix + +byteStringDataType :: DataType +byteStringDataType = mkNoRepType "Data.ByteString.ByteString" + +-- | @since 0.11.2.0 +instance TH.Lift ByteString where +#if MIN_VERSION_template_haskell(2,16,0) +-- template-haskell-2.16 first ships with ghc-8.10 + lift (BS ptr len) = [| unsafePackLenLiteral |] + `TH.appE` TH.litE (TH.integerL (fromIntegral len)) + `TH.appE` TH.litE (TH.BytesPrimL $ TH.Bytes ptr 0 (fromIntegral len)) +#else + lift bs@(BS _ len) = [| unsafePackLenLiteral |] + `TH.appE` TH.litE (TH.integerL (fromIntegral len)) + `TH.appE` TH.litE (TH.StringPrimL $ unpackBytes bs) +#endif + +#if MIN_VERSION_template_haskell(2,17,0) +-- template-haskell-2.17 first ships with ghc-9.0 + liftTyped = TH.unsafeCodeCoerce . TH.lift +#elif MIN_VERSION_template_haskell(2,16,0) +-- template-haskell-2.16 first ships with ghc-8.10 + liftTyped = TH.unsafeTExpCoerce . TH.lift +#endif + +------------------------------------------------------------------------ +-- Internal indexing + +-- | 'findIndexOrLength' is a variant of findIndex, that returns the length +-- of the string if no element is found, rather than Nothing. +findIndexOrLength :: (Word8 -> Bool) -> ByteString -> Int +findIndexOrLength k (BS x l) = + accursedUnutterablePerformIO $ g x + where + g ptr = go 0 + where + go !n | n >= l = return l + | otherwise = do w <- peekFp $ ptr `plusForeignPtr` n + if k w + then return n + else go (n+1) +{-# INLINE findIndexOrLength #-} + +------------------------------------------------------------------------ +-- Packing and unpacking from lists + +packBytes :: [Word8] -> ByteString +packBytes ws = unsafePackLenBytes (List.length ws) ws + +packChars :: [Char] -> ByteString +packChars cs = unsafePackLenChars (List.length cs) cs + +{-# INLINE [0] packChars #-} + +{-# RULES +"ByteString packChars/packAddress" forall s . + packChars (unpackCString# s) = unsafePackLiteral s + #-} + +unsafePackLenBytes :: Int -> [Word8] -> ByteString +unsafePackLenBytes len xs0 = + unsafeCreateFp len $ \p -> go p xs0 + where + go !_ [] = return () + go !p (x:xs) = pokeFp p x >> go (p `plusForeignPtr` 1) xs + +unsafePackLenChars :: Int -> [Char] -> ByteString +unsafePackLenChars len cs0 = + unsafeCreateFp len $ \p -> go p cs0 + where + go !_ [] = return () + go !p (c:cs) = pokeFp p (c2w c) >> go (p `plusForeignPtr` 1) cs + + +-- | /O(n)/ Pack a null-terminated sequence of bytes, pointed to by an +-- Addr\# (an arbitrary machine address assumed to point outside the +-- garbage-collected heap) into a @ByteString@. A much faster way to +-- create an 'Addr#' is with an unboxed string literal, than to pack a +-- boxed string. A unboxed string literal is compiled to a static @char +-- []@ by GHC. Establishing the length of the string requires a call to +-- @strlen(3)@, so the 'Addr#' must point to a null-terminated buffer (as +-- is the case with @\"string\"\#@ literals in GHC). Use 'Data.ByteString.Unsafe.unsafePackAddressLen' +-- if you know the length of the string statically. +-- +-- An example: +-- +-- > literalFS = unsafePackAddress "literal"# +-- +-- This function is /unsafe/. If you modify the buffer pointed to by the +-- original 'Addr#' this modification will be reflected in the resulting +-- @ByteString@, breaking referential transparency. +-- +-- Note this also won't work if your 'Addr#' has embedded @\'\\0\'@ characters in +-- the string, as @strlen@ will return too short a length. +-- +unsafePackAddress :: Addr# -> IO ByteString +unsafePackAddress addr# = do +#if HS_cstringLength_AND_FinalPtr_AVAILABLE + unsafePackLenAddress (I# (cstringLength# addr#)) addr# +#else + l <- c_strlen (Ptr addr#) + unsafePackLenAddress (fromIntegral l) addr# +#endif +{-# INLINE unsafePackAddress #-} + +-- | See 'unsafePackAddress'. This function is similar, +-- but takes an additional length argument rather then computing +-- it with @strlen@. +-- Therefore embedding @\'\\0\'@ characters is possible. +-- +-- @since 0.11.2.0 +unsafePackLenAddress :: Int -> Addr# -> IO ByteString +unsafePackLenAddress len addr# = do +#if HS_cstringLength_AND_FinalPtr_AVAILABLE + return (BS (ForeignPtr addr# FinalPtr) len) +#else + p <- newForeignPtr_ (Ptr addr#) + return $ BS p len +#endif +{-# INLINE unsafePackLenAddress #-} + +-- | See 'unsafePackAddress'. This function has similar behavior. Prefer +-- this function when the address in known to be an @Addr#@ literal. In +-- that context, there is no need for the sequencing guarantees that 'IO' +-- provides. On GHC 9.0 and up, this function uses the @FinalPtr@ data +-- constructor for @ForeignPtrContents@. +-- +-- @since 0.11.1.0 +unsafePackLiteral :: Addr# -> ByteString +unsafePackLiteral addr# = +#if HS_cstringLength_AND_FinalPtr_AVAILABLE + unsafePackLenLiteral (I# (cstringLength# addr#)) addr# +#else + let len = accursedUnutterablePerformIO (c_strlen (Ptr addr#)) + in unsafePackLenLiteral (fromIntegral len) addr# +#endif +{-# INLINE unsafePackLiteral #-} + + +-- | See 'unsafePackLiteral'. This function is similar, +-- but takes an additional length argument rather then computing +-- it with @strlen@. +-- Therefore embedding @\'\\0\'@ characters is possible. +-- +-- @since 0.11.2.0 +unsafePackLenLiteral :: Int -> Addr# -> ByteString +unsafePackLenLiteral len addr# = +#if HS_cstringLength_AND_FinalPtr_AVAILABLE + BS (ForeignPtr addr# FinalPtr) len +#else + -- newForeignPtr_ allocates a MutVar# internally. If that MutVar# + -- gets commoned up with the MutVar# of some unrelated ForeignPtr, + -- it may prevent automatic finalization for that other ForeignPtr. + -- So we avoid accursedUnutterablePerformIO here. + BS (unsafeDupablePerformIO (newForeignPtr_ (Ptr addr#))) len +#endif +{-# INLINE unsafePackLenLiteral #-} + +packUptoLenBytes :: Int -> [Word8] -> (ByteString, [Word8]) +packUptoLenBytes len xs0 = + unsafeCreateFpUptoN' len $ \p0 -> + let p_end = plusForeignPtr p0 len + go !p [] = return (p `minusForeignPtr` p0, []) + go !p xs | p == p_end = return (len, xs) + go !p (x:xs) = pokeFp p x >> go (p `plusForeignPtr` 1) xs + in go p0 xs0 + +packUptoLenChars :: Int -> [Char] -> (ByteString, [Char]) +packUptoLenChars len cs0 = + unsafeCreateFpUptoN' len $ \p0 -> + let p_end = plusForeignPtr p0 len + go !p [] = return (p `minusForeignPtr` p0, []) + go !p cs | p == p_end = return (len, cs) + go !p (c:cs) = pokeFp p (c2w c) >> go (p `plusForeignPtr` 1) cs + in go p0 cs0 + +-- Unpacking bytestrings into lists efficiently is a tradeoff: on the one hand +-- we would like to write a tight loop that just blasts the list into memory, on +-- the other hand we want it to be unpacked lazily so we don't end up with a +-- massive list data structure in memory. +-- +-- Our strategy is to combine both: we will unpack lazily in reasonable sized +-- chunks, where each chunk is unpacked strictly. +-- +-- unpackBytes and unpackChars do the lazy loop, while unpackAppendBytes and +-- unpackAppendChars do the chunks strictly. + +unpackBytes :: ByteString -> [Word8] +unpackBytes bs = unpackAppendBytesLazy bs [] + +unpackChars :: ByteString -> [Char] +unpackChars bs = unpackAppendCharsLazy bs [] + +unpackAppendBytesLazy :: ByteString -> [Word8] -> [Word8] +unpackAppendBytesLazy (BS fp len) xs + | len <= 100 = unpackAppendBytesStrict (BS fp len) xs + | otherwise = unpackAppendBytesStrict (BS fp 100) remainder + where + remainder = unpackAppendBytesLazy (BS (plusForeignPtr fp 100) (len-100)) xs + + -- Why 100 bytes you ask? Because on a 64bit machine the list we allocate + -- takes just shy of 4k which seems like a reasonable amount. + -- (5 words per list element, 8 bytes per word, 100 elements = 4000 bytes) + +unpackAppendCharsLazy :: ByteString -> [Char] -> [Char] +unpackAppendCharsLazy (BS fp len) cs + | len <= 100 = unpackAppendCharsStrict (BS fp len) cs + | otherwise = unpackAppendCharsStrict (BS fp 100) remainder + where + remainder = unpackAppendCharsLazy (BS (plusForeignPtr fp 100) (len-100)) cs + +-- For these unpack functions, since we're unpacking the whole list strictly we +-- build up the result list in an accumulator. This means we have to build up +-- the list starting at the end. So our traversal starts at the end of the +-- buffer and loops down until we hit the sentinal: + +unpackAppendBytesStrict :: ByteString -> [Word8] -> [Word8] +unpackAppendBytesStrict (BS fp len) xs = + accursedUnutterablePerformIO $ unsafeWithForeignPtr fp $ \base -> + loop (base `plusPtr` (-1)) (base `plusPtr` (-1+len)) xs + where + loop !sentinal !p acc + | p == sentinal = return acc + | otherwise = do x <- peek p + loop sentinal (p `plusPtr` (-1)) (x:acc) + +unpackAppendCharsStrict :: ByteString -> [Char] -> [Char] +unpackAppendCharsStrict (BS fp len) xs = + accursedUnutterablePerformIO $ unsafeWithForeignPtr fp $ \base -> + loop (base `plusPtr` (-1)) (base `plusPtr` (-1+len)) xs + where + loop !sentinal !p acc + | p == sentinal = return acc + | otherwise = do x <- peek p + loop sentinal (p `plusPtr` (-1)) (w2c x:acc) + +------------------------------------------------------------------------ + +-- | The 0 pointer. Used to indicate the empty Bytestring. +nullForeignPtr :: ForeignPtr Word8 +#if HS_cstringLength_AND_FinalPtr_AVAILABLE +nullForeignPtr = ForeignPtr nullAddr# FinalPtr +#else +nullForeignPtr = ForeignPtr nullAddr# (error "nullForeignPtr") +#endif + +-- --------------------------------------------------------------------- +-- Low level constructors + +-- | /O(1)/ Build a ByteString from a ForeignPtr. +-- +-- If you do not need the offset parameter then you should be using +-- 'Data.ByteString.Unsafe.unsafePackCStringLen' or +-- 'Data.ByteString.Unsafe.unsafePackCStringFinalizer' instead. +-- +fromForeignPtr :: ForeignPtr Word8 + -> Int -- ^ Offset + -> Int -- ^ Length + -> ByteString +fromForeignPtr fp o = BS (plusForeignPtr fp o) +{-# INLINE fromForeignPtr #-} + +-- | @since 0.11.0.0 +fromForeignPtr0 :: ForeignPtr Word8 + -> Int -- ^ Length + -> ByteString +fromForeignPtr0 = BS +{-# INLINE fromForeignPtr0 #-} + +-- | /O(1)/ Deconstruct a ForeignPtr from a ByteString +toForeignPtr :: ByteString -> (ForeignPtr Word8, Int, Int) -- ^ (ptr, offset, length) +toForeignPtr (BS ps l) = (ps, 0, l) +{-# INLINE toForeignPtr #-} + +-- | /O(1)/ Deconstruct a ForeignPtr from a ByteString +-- +-- @since 0.11.0.0 +toForeignPtr0 :: ByteString -> (ForeignPtr Word8, Int) -- ^ (ptr, length) +toForeignPtr0 (BS ps l) = (ps, l) +{-# INLINE toForeignPtr0 #-} + +-- | A way of creating ByteStrings outside the IO monad. The @Int@ +-- argument gives the final size of the ByteString. +unsafeCreateFp :: Int -> (ForeignPtr Word8 -> IO ()) -> ByteString +unsafeCreateFp l f = unsafeDupablePerformIO (createFp l f) +{-# INLINE unsafeCreateFp #-} + +-- | Like 'unsafeCreateFp' but instead of giving the final size of the +-- ByteString, it is just an upper bound. The inner action returns +-- the actual size. Unlike 'createFpAndTrim' the ByteString is not +-- reallocated if the final size is less than the estimated size. +unsafeCreateFpUptoN :: Int -> (ForeignPtr Word8 -> IO Int) -> ByteString +unsafeCreateFpUptoN l f = unsafeDupablePerformIO (createFpUptoN l f) +{-# INLINE unsafeCreateFpUptoN #-} + +unsafeCreateFpUptoN' + :: Int -> (ForeignPtr Word8 -> IO (Int, a)) -> (ByteString, a) +unsafeCreateFpUptoN' l f = unsafeDupablePerformIO (createFpUptoN' l f) +{-# INLINE unsafeCreateFpUptoN' #-} + +-- | Create ByteString of size @l@ and use action @f@ to fill its contents. +createFp :: Int -> (ForeignPtr Word8 -> IO ()) -> IO ByteString +createFp len action = assert (len >= 0) $ do + fp <- mallocByteString len + action fp + mkDeferredByteString fp len +{-# INLINE createFp #-} + +-- | Given a maximum size @l@ and an action @f@ that fills the 'ByteString' +-- starting at the given 'Ptr' and returns the actual utilized length, +-- @`createFpUptoN'` l f@ returns the filled 'ByteString'. +createFpUptoN :: Int -> (ForeignPtr Word8 -> IO Int) -> IO ByteString +createFpUptoN maxLen action = assert (maxLen >= 0) $ do + fp <- mallocByteString maxLen + len <- action fp + assert (0 <= len && len <= maxLen) $ mkDeferredByteString fp len +{-# INLINE createFpUptoN #-} + +-- | Like 'createFpUptoN', but also returns an additional value created by the +-- action. +createFpUptoN' :: Int -> (ForeignPtr Word8 -> IO (Int, a)) -> IO (ByteString, a) +createFpUptoN' maxLen action = assert (maxLen >= 0) $ do + fp <- mallocByteString maxLen + (len, res) <- action fp + bs <- mkDeferredByteString fp len + assert (0 <= len && len <= maxLen) $ pure (bs, res) +{-# INLINE createFpUptoN' #-} + +-- | Given the maximum size needed and a function to make the contents +-- of a ByteString, createFpAndTrim makes the 'ByteString'. The generating +-- function is required to return the actual final size (<= the maximum +-- size), and the resulting byte array is reallocated to this size. +-- +-- createFpAndTrim is the main mechanism for creating custom, efficient +-- ByteString functions, using Haskell or C functions to fill the space. +-- +createFpAndTrim :: Int -> (ForeignPtr Word8 -> IO Int) -> IO ByteString +createFpAndTrim maxLen action = assert (maxLen >= 0) $ do + fp <- mallocByteString maxLen + len <- action fp + if assert (0 <= len && len <= maxLen) $ len >= maxLen + then mkDeferredByteString fp maxLen + else createFp len $ \dest -> memcpyFp dest fp len +{-# INLINE createFpAndTrim #-} + +createFpAndTrim' :: Int -> (ForeignPtr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a) +createFpAndTrim' maxLen action = assert (maxLen >= 0) $ do + fp <- mallocByteString maxLen + (off, len, res) <- action fp + assert ( + 0 <= len && len <= maxLen && -- length OK + (len == 0 || (0 <= off && off <= maxLen - len)) -- offset OK + ) $ pure () + bs <- if len >= maxLen + then mkDeferredByteString fp maxLen -- entire buffer used => offset is zero + else createFp len $ \dest -> + memcpyFp dest (fp `plusForeignPtr` off) len + return (bs, res) +{-# INLINE createFpAndTrim' #-} + + +wrapAction :: (Ptr Word8 -> IO res) -> ForeignPtr Word8 -> IO res +wrapAction = flip withForeignPtr + -- Cannot use unsafeWithForeignPtr, because action can diverge + +-- | A way of creating ByteStrings outside the IO monad. The @Int@ +-- argument gives the final size of the ByteString. +unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> ByteString +unsafeCreate l f = unsafeCreateFp l (wrapAction f) +{-# INLINE unsafeCreate #-} + +-- | Like 'unsafeCreate' but instead of giving the final size of the +-- ByteString, it is just an upper bound. The inner action returns +-- the actual size. Unlike 'createAndTrim' the ByteString is not +-- reallocated if the final size is less than the estimated size. +unsafeCreateUptoN :: Int -> (Ptr Word8 -> IO Int) -> ByteString +unsafeCreateUptoN l f = unsafeCreateFpUptoN l (wrapAction f) +{-# INLINE unsafeCreateUptoN #-} + +-- | @since 0.10.12.0 +unsafeCreateUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> (ByteString, a) +unsafeCreateUptoN' l f = unsafeCreateFpUptoN' l (wrapAction f) +{-# INLINE unsafeCreateUptoN' #-} + +-- | Create ByteString of size @l@ and use action @f@ to fill its contents. +create :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString +create l action = createFp l (wrapAction action) +{-# INLINE create #-} + +-- | Given a maximum size @l@ and an action @f@ that fills the 'ByteString' +-- starting at the given 'Ptr' and returns the actual utilized length, +-- @`createUptoN'` l f@ returns the filled 'ByteString'. +createUptoN :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString +createUptoN l action = createFpUptoN l (wrapAction action) +{-# INLINE createUptoN #-} + +-- | Like 'createUptoN', but also returns an additional value created by the +-- action. +-- +-- @since 0.10.12.0 +createUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> IO (ByteString, a) +createUptoN' l action = createFpUptoN' l (wrapAction action) +{-# INLINE createUptoN' #-} + +-- | Given the maximum size needed and a function to make the contents +-- of a ByteString, createAndTrim makes the 'ByteString'. The generating +-- function is required to return the actual final size (<= the maximum +-- size), and the resulting byte array is reallocated to this size. +-- +-- createAndTrim is the main mechanism for creating custom, efficient +-- ByteString functions, using Haskell or C functions to fill the space. +-- +createAndTrim :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString +createAndTrim l action = createFpAndTrim l (wrapAction action) +{-# INLINE createAndTrim #-} + +createAndTrim' :: Int -> (Ptr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a) +createAndTrim' l action = createFpAndTrim' l (wrapAction action) +{-# INLINE createAndTrim' #-} + + +-- | Wrapper of 'Foreign.ForeignPtr.mallocForeignPtrBytes' with faster implementation for GHC +-- +mallocByteString :: Int -> IO (ForeignPtr a) +mallocByteString = mallocPlainForeignPtrBytes +{-# INLINE mallocByteString #-} + +------------------------------------------------------------------------ +-- Implementations for Eq, Ord and Monoid instances + +eq :: ByteString -> ByteString -> Bool +eq a@(BS fp len) b@(BS fp' len') + | len /= len' = False -- short cut on length + | fp == fp' = True -- short cut for the same string + | otherwise = compareBytes a b == EQ +{-# INLINE eq #-} +-- ^ still needed + +compareBytes :: ByteString -> ByteString -> Ordering +compareBytes (BS _ 0) (BS _ 0) = EQ -- short cut for empty strings +compareBytes (BS fp1 len1) (BS fp2 len2) = + accursedUnutterablePerformIO $ + unsafeWithForeignPtr fp1 $ \p1 -> + unsafeWithForeignPtr fp2 $ \p2 -> do + i <- memcmp p1 p2 (min len1 len2) + return $! case i `compare` 0 of + EQ -> len1 `compare` len2 + x -> x + + +-- | /O(1)/ The empty 'ByteString' +empty :: ByteString +-- This enables bypassing #457 by not using (polymorphic) mempty in +-- any definitions used by the (Monoid ByteString) instance +empty = BS nullForeignPtr 0 + +append :: ByteString -> ByteString -> ByteString +append (BS _ 0) b = b +append a (BS _ 0) = a +append (BS fp1 len1) (BS fp2 len2) = + unsafeCreateFp (checkedAdd "append" len1 len2) $ \destptr1 -> do + let destptr2 = destptr1 `plusForeignPtr` len1 + memcpyFp destptr1 fp1 len1 + memcpyFp destptr2 fp2 len2 + +concat :: [ByteString] -> ByteString +concat = \bss0 -> goLen0 bss0 bss0 + -- The idea here is we first do a pass over the input list to determine: + -- + -- 1. is a copy necessary? e.g. @concat []@, @concat [mempty, "hello"]@, + -- and @concat ["hello", mempty, mempty]@ can all be handled without + -- copying. + -- 2. if a copy is necessary, how large is the result going to be? + -- + -- If a copy is necessary then we create a buffer of the appropriate size + -- and do another pass over the input list, copying the chunks into the + -- buffer. Also, since foreign calls aren't entirely free we skip over + -- empty chunks while copying. + -- + -- We pass the original [ByteString] (bss0) through as an argument through + -- goLen0, goLen1, and goLen since we will need it again in goCopy. Passing + -- it as an explicit argument avoids capturing it in these functions' + -- closures which would result in unnecessary closure allocation. + where + -- It's still possible that the result is empty + goLen0 _ [] = empty + goLen0 bss0 (BS _ 0 :bss) = goLen0 bss0 bss + goLen0 bss0 (bs :bss) = goLen1 bss0 bs bss + + -- It's still possible that the result is a single chunk + goLen1 _ bs [] = bs + goLen1 bss0 bs (BS _ 0 :bss) = goLen1 bss0 bs bss + goLen1 bss0 bs (BS _ len:bss) = goLen bss0 (checkedAdd "concat" len' len) bss + where BS _ len' = bs + + -- General case, just find the total length we'll need + goLen bss0 !total (BS _ len:bss) = goLen bss0 total' bss + where total' = checkedAdd "concat" total len + goLen bss0 total [] = + unsafeCreateFp total $ \ptr -> goCopy bss0 ptr + + -- Copy the data + goCopy [] !_ = return () + goCopy (BS _ 0 :bss) !ptr = goCopy bss ptr + goCopy (BS fp len:bss) !ptr = do + memcpyFp ptr fp len + goCopy bss (ptr `plusForeignPtr` len) +{-# NOINLINE concat #-} + +{-# RULES +"ByteString concat [] -> empty" + concat [] = empty +"ByteString concat [bs] -> bs" forall x. + concat [x] = x + #-} + +-- | Repeats the given ByteString n times. +-- Polymorphic wrapper to make sure any generated +-- specializations are reasonably small. +stimesPolymorphic :: Integral a => a -> ByteString -> ByteString +{-# INLINABLE stimesPolymorphic #-} +stimesPolymorphic nRaw !bs = case checkedIntegerToInt n of + Just nInt + | nInt >= 0 -> stimesNonNegativeInt nInt bs + | otherwise -> stimesNegativeErr + Nothing + | n < 0 -> stimesNegativeErr + | BS _ 0 <- bs -> empty + | otherwise -> stimesOverflowErr + where n = toInteger nRaw + -- By exclusively using n instead of nRaw, the semantics are kept simple + -- and the likelihood of potentially dangerous mistakes minimized. + + +{- +Note [Float error calls out of INLINABLE things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If a function is marked INLINE or INLINABLE, then when ghc inlines or +specializes it, it duplicates the function body exactly as written. + +This feature is useful for systems of rewrite rules, but sometimes +comes at a code-size cost. One situation where this cost generally +comes with no compensating up-side is when the function in question +calls `error` or something similar. + +Such an `error` call is not meaningfully improved by the extra context +inlining or specialization provides, and if inlining or specialization +happens in a different module from where the function was originally +defined, CSE will not be able to de-duplicate the error call floated +out of the inlined RHS and the error call floated out of the original +RHS. See also https://gitlab.haskell.org/ghc/ghc/-/issues/23823 + +To mitigate this, we manually float the error calls out of INLINABLE +functions when it is possible to do so. +-} + +stimesNegativeErr :: ByteString +-- See Note [Float error calls out of INLINABLE things] +stimesNegativeErr + = errorWithoutStackTrace "stimes @ByteString: non-negative multiplier expected" + +stimesOverflowErr :: ByteString +-- See Note [Float error calls out of INLINABLE things] +stimesOverflowErr = overflowError "stimes" + +-- | Repeats the given ByteString n times. +stimesNonNegativeInt :: Int -> ByteString -> ByteString +stimesNonNegativeInt n (BS fp len) + | n == 0 = empty + | n == 1 = BS fp len + | len == 0 = empty + | len == 1 = unsafeCreateFp n $ \destfptr -> do + byte <- peekFp fp + unsafeWithForeignPtr destfptr $ \destptr -> + fillBytes destptr byte n + | otherwise = unsafeCreateFp size $ \destptr -> do + memcpyFp destptr fp len + fillFrom destptr len + where + size = checkedMultiply "stimes" n len + halfSize = (size - 1) `div` 2 -- subtraction and division won't overflow + + fillFrom :: ForeignPtr Word8 -> Int -> IO () + fillFrom destptr copied + | copied <= halfSize = do + memcpyFp (destptr `plusForeignPtr` copied) destptr copied + fillFrom destptr (copied * 2) + | otherwise = memcpyFp (destptr `plusForeignPtr` copied) destptr (size - copied) + + +------------------------------------------------------------------------ + +-- | Conversion between 'Word8' and 'Char'. Should compile to a no-op. +w2c :: Word8 -> Char +w2c = unsafeChr . fromIntegral +{-# INLINE w2c #-} + +-- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and +-- silently truncates to 8 bits Chars > '\255'. It is provided as +-- convenience for ByteString construction. +c2w :: Char -> Word8 +c2w = fromIntegral . ord +{-# INLINE c2w #-} + +-- | Selects words corresponding to white-space characters in the Latin-1 range +isSpaceWord8 :: Word8 -> Bool +isSpaceWord8 w8 = + -- Avoid the cost of narrowing arithmetic results to Word8, + -- the conversion from Word8 to Word is free. + let w :: Word + !w = fromIntegral w8 + in w .&. 0x50 == 0 -- Quick non-whitespace filter + && w - 0x21 > 0x7e -- Second non-whitespace filter + && ( w == 0x20 -- SP + || w == 0xa0 -- NBSP + || w - 0x09 < 5) -- HT, NL, VT, FF, CR +{-# INLINE isSpaceWord8 #-} + +-- | Selects white-space characters in the Latin-1 range +isSpaceChar8 :: Char -> Bool +isSpaceChar8 = isSpaceWord8 . c2w +{-# INLINE isSpaceChar8 #-} + +------------------------------------------------------------------------ + +-- | The type of exception raised by 'overflowError' +-- and on failure by overflow-checked arithmetic operations. +newtype SizeOverflowException + = SizeOverflowException String + +instance Show SizeOverflowException where + show (SizeOverflowException err) = err + +instance Exception SizeOverflowException + +-- | Raises a 'SizeOverflowException', +-- with a message using the given function name. +overflowError :: String -> a +overflowError fun = throw $ SizeOverflowException msg + where msg = "Data.ByteString." ++ fun ++ ": size overflow" + +-- | Add two non-negative numbers. +-- Calls 'overflowError' on overflow. +checkedAdd :: String -> Int -> Int -> Int +{-# INLINE checkedAdd #-} +checkedAdd fun x y + -- checking "r < 0" here matches the condition in mallocPlainForeignPtrBytes, + -- helping the compiler see the latter is redundant in some places + | r < 0 = overflowError fun + | otherwise = r + where r = assert (min x y >= 0) $ x + y + +-- | Multiplies two non-negative numbers. +-- Calls 'overflowError' on overflow. +checkedMultiply :: String -> Int -> Int -> Int +{-# INLINE checkedMultiply #-} +checkedMultiply fun !x@(I# x#) !y@(I# y#) = assert (min x y >= 0) $ +#if HS_timesInt2_PRIMOP_AVAILABLE + case timesInt2# x# y# of + (# 0#, _, result #) -> I# result + _ -> overflowError fun +#else + case timesWord2# (int2Word# x#) (int2Word# y#) of + (# hi, lo #) -> case or# hi (uncheckedShiftRL# lo shiftAmt) of + 0## -> I# (word2Int# lo) + _ -> overflowError fun + where !(I# shiftAmt) = finiteBitSize (0 :: Word) - 1 +#endif + + +-- | Attempts to convert an 'Integer' value to an 'Int', returning +-- 'Nothing' if doing so would result in an overflow. +checkedIntegerToInt :: Integer -> Maybe Int +{-# INLINE checkedIntegerToInt #-} +-- We could use Data.Bits.toIntegralSized, but this hand-rolled +-- version is currently a bit faster as of GHC 9.2. +-- It's even faster to just match on the Integer constructors, but +-- we'd still need a fallback implementation for integer-simple. +checkedIntegerToInt x + | x == toInteger res = Just res + | otherwise = Nothing + where res = fromInteger x :: Int + + +------------------------------------------------------------------------ + +-- | This \"function\" has a superficial similarity to 'System.IO.Unsafe.unsafePerformIO' but +-- it is in fact a malevolent agent of chaos. It unpicks the seams of reality +-- (and the 'IO' monad) so that the normal rules no longer apply. It lulls you +-- into thinking it is reasonable, but when you are not looking it stabs you +-- in the back and aliases all of your mutable buffers. The carcass of many a +-- seasoned Haskell programmer lie strewn at its feet. +-- +-- Witness the trail of destruction: +-- +-- * +-- +-- * +-- +-- * +-- +-- * +-- +-- * +-- +-- * +-- +-- * +-- +-- Do not talk about \"safe\"! You do not know what is safe! +-- +-- Yield not to its blasphemous call! Flee traveller! Flee or you will be +-- corrupted and devoured! +-- +{-# INLINE accursedUnutterablePerformIO #-} +accursedUnutterablePerformIO :: IO a -> a +accursedUnutterablePerformIO (IO m) = case m realWorld# of (# _, r #) -> r + +-- --------------------------------------------------------------------- +-- +-- Standard C functions +-- + +memchr :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8) +memcmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO CInt +{-# DEPRECATED memset "Use Foreign.Marshal.Utils.fillBytes instead" #-} +-- | deprecated since @bytestring-0.11.5.0@ +memset :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8) + +#if !PURE_HASKELL + +foreign import ccall unsafe "string.h strlen" c_strlen + :: CString -> IO CSize + +foreign import ccall unsafe "string.h memchr" c_memchr + :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8) +memchr p w sz = c_memchr p (fromIntegral w) sz + +foreign import ccall unsafe "string.h memcmp" c_memcmp + :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt +memcmp p q s = c_memcmp p q (fromIntegral s) + +foreign import ccall unsafe "string.h memset" c_memset + :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8) +memset p w sz = c_memset p (fromIntegral w) sz + +#else + +c_strlen :: CString -> IO CSize +c_strlen p = checkedCast <$!> Pure.strlen (castPtr p) + +memchr p w len = Pure.memchr p w (checkedCast len) + +memcmp p q s = checkedCast <$!> Pure.memcmp p q s + +memset p w len = p <$ fillBytes p w (checkedCast len) + +#endif + +{-# DEPRECATED memcpy "Use Foreign.Marshal.Utils.copyBytes instead" #-} +-- | deprecated since @bytestring-0.11.5.0@ +memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () +memcpy = copyBytes + +memcpyFp :: ForeignPtr Word8 -> ForeignPtr Word8 -> Int -> IO () +memcpyFp fp fq s = unsafeWithForeignPtr fp $ \p -> + unsafeWithForeignPtr fq $ \q -> copyBytes p q s + +c_free_finalizer :: FunPtr (Ptr Word8 -> IO ()) +c_free_finalizer = finalizerFree + + + +-- --------------------------------------------------------------------- +-- +-- Uses our C code +-- + +#if !PURE_HASKELL + +foreign import ccall unsafe "static fpstring.h fps_reverse" c_reverse + :: Ptr Word8 -> Ptr Word8 -> CSize -> IO () + +foreign import ccall unsafe "static fpstring.h fps_intersperse" c_intersperse + :: Ptr Word8 -> Ptr Word8 -> CSize -> Word8 -> IO () + +foreign import ccall unsafe "static fpstring.h fps_maximum" c_maximum + :: Ptr Word8 -> CSize -> IO Word8 + +foreign import ccall unsafe "static fpstring.h fps_minimum" c_minimum + :: Ptr Word8 -> CSize -> IO Word8 + +foreign import ccall unsafe "static fpstring.h fps_count" c_count + :: Ptr Word8 -> CSize -> Word8 -> IO CSize + +-- fps_count works with both pointers and ByteArray# +foreign import ccall unsafe "static fpstring.h fps_count" c_count_ba + :: ByteArray# -> CSize -> Word8 -> IO CSize + +foreign import ccall unsafe "static fpstring.h fps_sort" c_sort + :: Ptr Word8 -> CSize -> IO () + +foreign import ccall unsafe "static sbs_elem_index" + c_elem_index :: ByteArray# -> Word8 -> CSize -> IO CPtrdiff + + + +foreign import ccall unsafe "static _hs_bytestring_uint_dec" c_uint_dec + :: CUInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_long_long_uint_dec" c_long_long_uint_dec + :: CULLong -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_int_dec" c_int_dec + :: CInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec" c_long_long_int_dec + :: CLLong -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_uint_hex" c_uint_hex + :: CUInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_long_long_uint_hex" c_long_long_uint_hex + :: CULLong -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_int_dec_padded9" + c_int_dec_padded9 :: CInt -> Ptr Word8 -> IO () + +foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec_padded18" + c_long_long_int_dec_padded18 :: CLLong -> Ptr Word8 -> IO () + +-- We import bytestring_is_valid_utf8 both unsafe and safe. For small inputs +-- we can use the unsafe version to get a bit more performance, but for large +-- inputs the safe version should be used to avoid GC synchronization pauses +-- in multithreaded contexts. + +foreign import ccall unsafe "bytestring_is_valid_utf8" cIsValidUtf8BA + :: ByteArray# -> CSize -> IO CInt + +foreign import ccall safe "bytestring_is_valid_utf8" cIsValidUtf8BASafe + :: ByteArray# -> CSize -> IO CInt + +foreign import ccall unsafe "bytestring_is_valid_utf8" cIsValidUtf8 + :: Ptr Word8 -> CSize -> IO CInt + +foreign import ccall safe "bytestring_is_valid_utf8" cIsValidUtf8Safe + :: Ptr Word8 -> CSize -> IO CInt + + +#else + +---------------------------------------------------------------- +-- Haskell version of functions in fpstring.c +---------------------------------------------------------------- + +-- | Reverse n-bytes from the second pointer into the first +c_reverse :: Ptr Word8 -> Ptr Word8 -> CSize -> IO () +c_reverse p1 p2 sz = Pure.reverseBytes p1 p2 (checkedCast sz) + +-- | find maximum char in a packed string +c_maximum :: Ptr Word8 -> CSize -> IO Word8 +c_maximum ptr sz = Pure.findMaximum ptr (checkedCast sz) + +-- | find minimum char in a packed string +c_minimum :: Ptr Word8 -> CSize -> IO Word8 +c_minimum ptr sz = Pure.findMinimum ptr (checkedCast sz) + +-- | count the number of occurrences of a char in a string +c_count :: Ptr Word8 -> CSize -> Word8 -> IO CSize +c_count ptr sz c = checkedCast <$!> Pure.countOcc ptr (checkedCast sz) c + +-- | count the number of occurrences of a char in a string +c_count_ba :: ByteArray# -> Int -> Word8 -> IO CSize +c_count_ba ba o c = checkedCast <$!> Pure.countOccBA ba o c + +-- | duplicate a string, interspersing the character through the elements of the +-- duplicated string +c_intersperse :: Ptr Word8 -> Ptr Word8 -> CSize -> Word8 -> IO () +c_intersperse p1 p2 sz e = Pure.intersperse p1 p2 (checkedCast sz) e + +-- | Quick sort bytes +c_sort :: Ptr Word8 -> CSize -> IO () +c_sort ptr sz = Pure.quickSort ptr (checkedCast sz) + +c_elem_index :: ByteArray# -> Word8 -> CSize -> IO CPtrdiff +c_elem_index ba e sz = checkedCast <$!> Pure.elemIndex ba e (checkedCast sz) + +cIsValidUtf8BA :: ByteArray# -> CSize -> IO CInt +cIsValidUtf8BA ba sz = bool_to_cint <$> Pure.isValidUtf8BA ba (checkedCast sz) + +cIsValidUtf8 :: Ptr Word8 -> CSize -> IO CInt +cIsValidUtf8 ptr sz = bool_to_cint <$> Pure.isValidUtf8 ptr (checkedCast sz) + +-- Pure module is compiled with `-fno-omit-yields` so it's always safe (it won't +-- block on large inputs) + +cIsValidUtf8BASafe :: ByteArray# -> CSize -> IO CInt +cIsValidUtf8BASafe = cIsValidUtf8BA + +cIsValidUtf8Safe :: Ptr Word8 -> CSize -> IO CInt +cIsValidUtf8Safe = cIsValidUtf8 + +bool_to_cint :: Bool -> CInt +bool_to_cint True = 1 +bool_to_cint False = 0 + +checkedCast :: (Bits a, Bits b, Integral a, Integral b) => a -> b +checkedCast x = + fromMaybe (errorWithoutStackTrace "checkedCast: overflow") + (toIntegralSized x) + +---------------------------------------------------------------- +-- Haskell version of functions in itoa.c +---------------------------------------------------------------- + +c_int_dec :: CInt -> Ptr Word8 -> IO (Ptr Word8) +c_int_dec = Pure.encodeSignedDec + +c_long_long_int_dec :: CLLong -> Ptr Word8 -> IO (Ptr Word8) +c_long_long_int_dec = Pure.encodeSignedDec + +c_uint_dec :: CUInt -> Ptr Word8 -> IO (Ptr Word8) +c_uint_dec = Pure.encodeUnsignedDec + +c_long_long_uint_dec :: CULLong -> Ptr Word8 -> IO (Ptr Word8) +c_long_long_uint_dec = Pure.encodeUnsignedDec + +c_uint_hex :: CUInt -> Ptr Word8 -> IO (Ptr Word8) +c_uint_hex = Pure.encodeUnsignedHex + +c_long_long_uint_hex :: CULLong -> Ptr Word8 -> IO (Ptr Word8) +c_long_long_uint_hex = Pure.encodeUnsignedHex + +c_int_dec_padded9 :: CInt -> Ptr Word8 -> IO () +c_int_dec_padded9 = Pure.encodeUnsignedDecPadded 9 + +c_long_long_int_dec_padded18 :: CLLong -> Ptr Word8 -> IO () +c_long_long_int_dec_padded18 = Pure.encodeUnsignedDecPadded 18 + +#endif diff --git a/Data/ByteString/Lazy.hs b/Data/ByteString/Lazy.hs --- a/Data/ByteString/Lazy.hs +++ b/Data/ByteString/Lazy.hs @@ -1,1344 +1,1790 @@ -{-# LANGUAGE CPP, BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -{-# OPTIONS_HADDOCK prune #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - --- | --- Module : Data.ByteString.Lazy --- Copyright : (c) Don Stewart 2006 --- (c) Duncan Coutts 2006-2011 --- License : BSD-style --- --- Maintainer : dons00@gmail.com, duncan@community.haskell.org --- Stability : stable --- Portability : portable --- --- A time and space-efficient implementation of lazy byte vectors --- using lists of packed 'Word8' arrays, suitable for high performance --- use, both in terms of large data quantities, or high speed --- requirements. Lazy ByteStrings are encoded as lazy lists of strict chunks --- of bytes. --- --- A key feature of lazy ByteStrings is the means to manipulate large or --- unbounded streams of data without requiring the entire sequence to be --- resident in memory. To take advantage of this you have to write your --- functions in a lazy streaming style, e.g. classic pipeline composition. The --- default I\/O chunk size is 32k, which should be good in most circumstances. --- --- Some operations, such as 'concat', 'append', 'reverse' and 'cons', have --- better complexity than their "Data.ByteString" equivalents, due to --- optimisations resulting from the list spine structure. For other --- operations lazy ByteStrings are usually within a few percent of --- strict ones. --- --- The recomended way to assemble lazy ByteStrings from smaller parts --- is to use the builder monoid from "Data.ByteString.Lazy.Builder". --- --- This module is intended to be imported @qualified@, to avoid name --- clashes with "Prelude" functions. eg. --- --- > import qualified Data.ByteString.Lazy as B --- --- Original GHC implementation by Bryan O\'Sullivan. --- Rewritten to use 'Data.Array.Unboxed.UArray' by Simon Marlow. --- Rewritten to support slices and use 'Foreign.ForeignPtr.ForeignPtr' --- by David Roundy. --- Rewritten again and extended by Don Stewart and Duncan Coutts. --- Lazy variant by Duncan Coutts and Don Stewart. --- - -module Data.ByteString.Lazy ( - - -- * The @ByteString@ type - ByteString, -- instances: Eq, Ord, Show, Read, Data, Typeable - - -- * Introducing and eliminating 'ByteString's - empty, -- :: ByteString - singleton, -- :: Word8 -> ByteString - pack, -- :: [Word8] -> ByteString - unpack, -- :: ByteString -> [Word8] - fromStrict, -- :: Strict.ByteString -> ByteString - toStrict, -- :: ByteString -> Strict.ByteString - fromChunks, -- :: [Strict.ByteString] -> ByteString - toChunks, -- :: ByteString -> [Strict.ByteString] - foldrChunks, -- :: (S.ByteString -> a -> a) -> a -> ByteString -> a - foldlChunks, -- :: (a -> S.ByteString -> a) -> a -> ByteString -> a - - -- * Basic interface - cons, -- :: Word8 -> ByteString -> ByteString - cons', -- :: Word8 -> ByteString -> ByteString - snoc, -- :: ByteString -> Word8 -> ByteString - append, -- :: ByteString -> ByteString -> ByteString - head, -- :: ByteString -> Word8 - uncons, -- :: ByteString -> Maybe (Word8, ByteString) - last, -- :: ByteString -> Word8 - tail, -- :: ByteString -> ByteString - init, -- :: ByteString -> ByteString - null, -- :: ByteString -> Bool - length, -- :: ByteString -> Int64 - - -- * Transforming ByteStrings - map, -- :: (Word8 -> Word8) -> ByteString -> ByteString - reverse, -- :: ByteString -> ByteString - intersperse, -- :: Word8 -> ByteString -> ByteString - intercalate, -- :: ByteString -> [ByteString] -> ByteString - transpose, -- :: [ByteString] -> [ByteString] - - -- * Reducing 'ByteString's (folds) - foldl, -- :: (a -> Word8 -> a) -> a -> ByteString -> a - foldl', -- :: (a -> Word8 -> a) -> a -> ByteString -> a - foldl1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 - foldl1', -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 - foldr, -- :: (Word8 -> a -> a) -> a -> ByteString -> a - foldr1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 - - -- ** Special folds - concat, -- :: [ByteString] -> ByteString - concatMap, -- :: (Word8 -> ByteString) -> ByteString -> ByteString - any, -- :: (Word8 -> Bool) -> ByteString -> Bool - all, -- :: (Word8 -> Bool) -> ByteString -> Bool - maximum, -- :: ByteString -> Word8 - minimum, -- :: ByteString -> Word8 - - -- * Building ByteStrings - -- ** Scans - scanl, -- :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString --- scanl1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString --- scanr, -- :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString --- scanr1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString - - -- ** Accumulating maps - mapAccumL, -- :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) - mapAccumR, -- :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) - - -- ** Infinite ByteStrings - repeat, -- :: Word8 -> ByteString - replicate, -- :: Int64 -> Word8 -> ByteString - cycle, -- :: ByteString -> ByteString - iterate, -- :: (Word8 -> Word8) -> Word8 -> ByteString - - -- ** Unfolding ByteStrings - unfoldr, -- :: (a -> Maybe (Word8, a)) -> a -> ByteString - - -- * Substrings - - -- ** Breaking strings - take, -- :: Int64 -> ByteString -> ByteString - drop, -- :: Int64 -> ByteString -> ByteString - splitAt, -- :: Int64 -> ByteString -> (ByteString, ByteString) - takeWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString - dropWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString - span, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) - break, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) - group, -- :: ByteString -> [ByteString] - groupBy, -- :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString] - inits, -- :: ByteString -> [ByteString] - tails, -- :: ByteString -> [ByteString] - - -- ** Breaking into many substrings - split, -- :: Word8 -> ByteString -> [ByteString] - splitWith, -- :: (Word8 -> Bool) -> ByteString -> [ByteString] - - -- * Predicates - isPrefixOf, -- :: ByteString -> ByteString -> Bool - isSuffixOf, -- :: ByteString -> ByteString -> Bool --- isInfixOf, -- :: ByteString -> ByteString -> Bool - - -- ** Search for arbitrary substrings --- isSubstringOf, -- :: ByteString -> ByteString -> Bool --- findSubstring, -- :: ByteString -> ByteString -> Maybe Int --- findSubstrings, -- :: ByteString -> ByteString -> [Int] - - -- * Searching ByteStrings - - -- ** Searching by equality - elem, -- :: Word8 -> ByteString -> Bool - notElem, -- :: Word8 -> ByteString -> Bool - - -- ** Searching with a predicate - find, -- :: (Word8 -> Bool) -> ByteString -> Maybe Word8 - filter, -- :: (Word8 -> Bool) -> ByteString -> ByteString - partition, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) - - -- * Indexing ByteStrings - index, -- :: ByteString -> Int64 -> Word8 - elemIndex, -- :: Word8 -> ByteString -> Maybe Int64 - elemIndices, -- :: Word8 -> ByteString -> [Int64] - findIndex, -- :: (Word8 -> Bool) -> ByteString -> Maybe Int64 - findIndices, -- :: (Word8 -> Bool) -> ByteString -> [Int64] - count, -- :: Word8 -> ByteString -> Int64 - - -- * Zipping and unzipping ByteStrings - zip, -- :: ByteString -> ByteString -> [(Word8,Word8)] - zipWith, -- :: (Word8 -> Word8 -> c) -> ByteString -> ByteString -> [c] - unzip, -- :: [(Word8,Word8)] -> (ByteString,ByteString) - - -- * Ordered ByteStrings --- sort, -- :: ByteString -> ByteString - - -- * Low level conversions - -- ** Copying ByteStrings - copy, -- :: ByteString -> ByteString --- defrag, -- :: ByteString -> ByteString - - -- * I\/O with 'ByteString's - - -- ** Standard input and output - getContents, -- :: IO ByteString - putStr, -- :: ByteString -> IO () - putStrLn, -- :: ByteString -> IO () - interact, -- :: (ByteString -> ByteString) -> IO () - - -- ** Files - readFile, -- :: FilePath -> IO ByteString - writeFile, -- :: FilePath -> ByteString -> IO () - appendFile, -- :: FilePath -> ByteString -> IO () - - -- ** I\/O with Handles - hGetContents, -- :: Handle -> IO ByteString - hGet, -- :: Handle -> Int -> IO ByteString - hGetNonBlocking, -- :: Handle -> Int -> IO ByteString - hPut, -- :: Handle -> ByteString -> IO () - hPutNonBlocking, -- :: Handle -> ByteString -> IO ByteString - hPutStr, -- :: Handle -> ByteString -> IO () - - ) where - -import Prelude hiding - (reverse,head,tail,last,init,null,length,map,lines,foldl,foldr,unlines - ,concat,any,take,drop,splitAt,takeWhile,dropWhile,span,break,elem,filter,maximum - ,minimum,all,concatMap,foldl1,foldr1,scanl, scanl1, scanr, scanr1 - ,repeat, cycle, interact, iterate,readFile,writeFile,appendFile,replicate - ,getContents,getLine,putStr,putStrLn ,zip,zipWith,unzip,notElem) - -import qualified Data.List as L -- L for list/lazy -import qualified Data.ByteString as P (ByteString) -- type name only -import qualified Data.ByteString as S -- S for strict (hmm...) -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Unsafe as S -import Data.ByteString.Lazy.Internal - -import Data.Monoid (Monoid(..)) - -import Data.Word (Word8) -import Data.Int (Int64) -import System.IO (Handle,stdin,stdout,openBinaryFile,IOMode(..) - ,hClose) -import System.IO.Error (mkIOError, illegalOperationErrorType) -import System.IO.Unsafe -#ifndef __NHC__ -import Control.Exception (bracket) -#else -import IO (bracket) -#endif - -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr -import Foreign.Storable - --- ----------------------------------------------------------------------------- --- --- Useful macros, until we have bang patterns --- - -#define STRICT1(f) f a | a `seq` False = undefined -#define STRICT2(f) f a b | a `seq` b `seq` False = undefined -#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined -#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined -#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined - --- ----------------------------------------------------------------------------- --- Introducing and eliminating 'ByteString's - --- | /O(1)/ The empty 'ByteString' -empty :: ByteString -empty = Empty -{-# INLINE empty #-} - --- | /O(1)/ Convert a 'Word8' into a 'ByteString' -singleton :: Word8 -> ByteString -singleton w = Chunk (S.singleton w) Empty -{-# INLINE singleton #-} - --- | /O(n)/ Convert a '[Word8]' into a 'ByteString'. -pack :: [Word8] -> ByteString -pack = packBytes - --- | /O(n)/ Converts a 'ByteString' to a '[Word8]'. -unpack :: ByteString -> [Word8] -unpack = unpackBytes - --- | /O(c)/ Convert a list of strict 'ByteString' into a lazy 'ByteString' -fromChunks :: [P.ByteString] -> ByteString -fromChunks cs = L.foldr chunk Empty cs - --- | /O(c)/ Convert a lazy 'ByteString' into a list of strict 'ByteString' -toChunks :: ByteString -> [P.ByteString] -toChunks cs = foldrChunks (:) [] cs - --- |/O(1)/ Convert a strict 'ByteString' into a lazy 'ByteString'. -fromStrict :: P.ByteString -> ByteString -fromStrict bs | S.null bs = Empty - | otherwise = Chunk bs Empty - --- |/O(n)/ Convert a lazy 'ByteString' into a strict 'ByteString'. --- --- Note that this is an /expensive/ operation that forces the whole lazy --- ByteString into memory and then copies all the data. If possible, try to --- avoid converting back and forth between strict and lazy bytestrings. --- -toStrict :: ByteString -> S.ByteString -toStrict Empty = S.empty -toStrict (Chunk c Empty) = c -toStrict cs0 = S.unsafeCreate totalLen $ \ptr -> go cs0 ptr - where - totalLen = foldlChunks (\a c -> a + S.length c) 0 cs0 - - go Empty !_ = return () - go (Chunk (S.PS fp off len) cs) !destptr = - withForeignPtr fp $ \p -> do - S.memcpy destptr (p `plusPtr` off) len - go cs (destptr `plusPtr` len) - ------------------------------------------------------------------------- - -{- --- | /O(n)/ Convert a '[a]' into a 'ByteString' using some --- conversion function -packWith :: (a -> Word8) -> [a] -> ByteString -packWith k str = LPS $ L.map (P.packWith k) (chunk defaultChunkSize str) -{-# INLINE packWith #-} -{-# SPECIALIZE packWith :: (Char -> Word8) -> [Char] -> ByteString #-} - --- | /O(n)/ Converts a 'ByteString' to a '[a]', using a conversion function. -unpackWith :: (Word8 -> a) -> ByteString -> [a] -unpackWith k (LPS ss) = L.concatMap (S.unpackWith k) ss -{-# INLINE unpackWith #-} -{-# SPECIALIZE unpackWith :: (Word8 -> Char) -> ByteString -> [Char] #-} --} - --- --------------------------------------------------------------------- --- Basic interface - --- | /O(1)/ Test whether a ByteString is empty. -null :: ByteString -> Bool -null Empty = True -null _ = False -{-# INLINE null #-} - --- | /O(n\/c)/ 'length' returns the length of a ByteString as an 'Int64' -length :: ByteString -> Int64 -length cs = foldlChunks (\n c -> n + fromIntegral (S.length c)) 0 cs -{-# INLINE length #-} - -infixr 5 `cons`, `cons'` --same as list (:) -infixl 5 `snoc` - --- | /O(1)/ 'cons' is analogous to '(:)' for lists. --- -cons :: Word8 -> ByteString -> ByteString -cons c cs = Chunk (S.singleton c) cs -{-# INLINE cons #-} - --- | /O(1)/ Unlike 'cons', 'cons\'' is --- strict in the ByteString that we are consing onto. More precisely, it forces --- the head and the first chunk. It does this because, for space efficiency, it --- may coalesce the new byte onto the first \'chunk\' rather than starting a --- new \'chunk\'. --- --- So that means you can't use a lazy recursive contruction like this: --- --- > let xs = cons\' c xs in xs --- --- You can however use 'cons', as well as 'repeat' and 'cycle', to build --- infinite lazy ByteStrings. --- -cons' :: Word8 -> ByteString -> ByteString -cons' w (Chunk c cs) | S.length c < 16 = Chunk (S.cons w c) cs -cons' w cs = Chunk (S.singleton w) cs -{-# INLINE cons' #-} - --- | /O(n\/c)/ Append a byte to the end of a 'ByteString' -snoc :: ByteString -> Word8 -> ByteString -snoc cs w = foldrChunks Chunk (singleton w) cs -{-# INLINE snoc #-} - --- | /O(1)/ Extract the first element of a ByteString, which must be non-empty. -head :: ByteString -> Word8 -head Empty = errorEmptyList "head" -head (Chunk c _) = S.unsafeHead c -{-# INLINE head #-} - --- | /O(1)/ Extract the head and tail of a ByteString, returning Nothing --- if it is empty. -uncons :: ByteString -> Maybe (Word8, ByteString) -uncons Empty = Nothing -uncons (Chunk c cs) - = Just (S.unsafeHead c, - if S.length c == 1 then cs else Chunk (S.unsafeTail c) cs) -{-# INLINE uncons #-} - --- | /O(1)/ Extract the elements after the head of a ByteString, which must be --- non-empty. -tail :: ByteString -> ByteString -tail Empty = errorEmptyList "tail" -tail (Chunk c cs) - | S.length c == 1 = cs - | otherwise = Chunk (S.unsafeTail c) cs -{-# INLINE tail #-} - --- | /O(n\/c)/ Extract the last element of a ByteString, which must be finite --- and non-empty. -last :: ByteString -> Word8 -last Empty = errorEmptyList "last" -last (Chunk c0 cs0) = go c0 cs0 - where go c Empty = S.last c - go _ (Chunk c cs) = go c cs --- XXX Don't inline this. Something breaks with 6.8.2 (haven't investigated yet) - --- | /O(n\/c)/ Return all the elements of a 'ByteString' except the last one. -init :: ByteString -> ByteString -init Empty = errorEmptyList "init" -init (Chunk c0 cs0) = go c0 cs0 - where go c Empty | S.length c == 1 = Empty - | otherwise = Chunk (S.init c) Empty - go c (Chunk c' cs) = Chunk c (go c' cs) - --- | /O(n\/c)/ Append two ByteStrings -append :: ByteString -> ByteString -> ByteString -append = mappend -{-# INLINE append #-} - --- --------------------------------------------------------------------- --- Transformations - --- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each --- element of @xs@. -map :: (Word8 -> Word8) -> ByteString -> ByteString -map f s = go s - where - go Empty = Empty - go (Chunk x xs) = Chunk y ys - where - y = S.map f x - ys = go xs -{-# INLINE map #-} - --- | /O(n)/ 'reverse' @xs@ returns the elements of @xs@ in reverse order. -reverse :: ByteString -> ByteString -reverse cs0 = rev Empty cs0 - where rev a Empty = a - rev a (Chunk c cs) = rev (Chunk (S.reverse c) a) cs -{-# INLINE reverse #-} - --- | The 'intersperse' function takes a 'Word8' and a 'ByteString' and --- \`intersperses\' that byte between the elements of the 'ByteString'. --- It is analogous to the intersperse function on Lists. -intersperse :: Word8 -> ByteString -> ByteString -intersperse _ Empty = Empty -intersperse w (Chunk c cs) = Chunk (S.intersperse w c) - (foldrChunks (Chunk . intersperse') Empty cs) - where intersperse' :: P.ByteString -> P.ByteString - intersperse' (S.PS fp o l) = - S.unsafeCreate (2*l) $ \p' -> withForeignPtr fp $ \p -> do - poke p' w - S.c_intersperse (p' `plusPtr` 1) (p `plusPtr` o) (fromIntegral l) w - --- | The 'transpose' function transposes the rows and columns of its --- 'ByteString' argument. -transpose :: [ByteString] -> [ByteString] -transpose css = L.map (\ss -> Chunk (S.pack ss) Empty) - (L.transpose (L.map unpack css)) ---TODO: make this fast - --- --------------------------------------------------------------------- --- Reducing 'ByteString's - --- | 'foldl', applied to a binary operator, a starting value (typically --- the left-identity of the operator), and a ByteString, reduces the --- ByteString using the binary operator, from left to right. -foldl :: (a -> Word8 -> a) -> a -> ByteString -> a -foldl f z = go z - where go a Empty = a - go a (Chunk c cs) = go (S.foldl f a c) cs -{-# INLINE foldl #-} - --- | 'foldl\'' is like 'foldl', but strict in the accumulator. -foldl' :: (a -> Word8 -> a) -> a -> ByteString -> a -foldl' f z = go z - where go a _ | a `seq` False = undefined - go a Empty = a - go a (Chunk c cs) = go (S.foldl f a c) cs -{-# INLINE foldl' #-} - --- | 'foldr', applied to a binary operator, a starting value --- (typically the right-identity of the operator), and a ByteString, --- reduces the ByteString using the binary operator, from right to left. -foldr :: (Word8 -> a -> a) -> a -> ByteString -> a -foldr k z cs = foldrChunks (flip (S.foldr k)) z cs -{-# INLINE foldr #-} - --- | 'foldl1' is a variant of 'foldl' that has no starting value --- argument, and thus must be applied to non-empty 'ByteStrings'. -foldl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 -foldl1 _ Empty = errorEmptyList "foldl1" -foldl1 f (Chunk c cs) = foldl f (S.unsafeHead c) (Chunk (S.unsafeTail c) cs) - --- | 'foldl1\'' is like 'foldl1', but strict in the accumulator. -foldl1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 -foldl1' _ Empty = errorEmptyList "foldl1'" -foldl1' f (Chunk c cs) = foldl' f (S.unsafeHead c) (Chunk (S.unsafeTail c) cs) - --- | 'foldr1' is a variant of 'foldr' that has no starting value argument, --- and thus must be applied to non-empty 'ByteString's -foldr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 -foldr1 _ Empty = errorEmptyList "foldr1" -foldr1 f (Chunk c0 cs0) = go c0 cs0 - where go c Empty = S.foldr1 f c - go c (Chunk c' cs) = S.foldr f (go c' cs) c - --- --------------------------------------------------------------------- --- Special folds - --- | /O(n)/ Concatenate a list of ByteStrings. -concat :: [ByteString] -> ByteString -concat = mconcat - --- | Map a function over a 'ByteString' and concatenate the results -concatMap :: (Word8 -> ByteString) -> ByteString -> ByteString -concatMap _ Empty = Empty -concatMap f (Chunk c0 cs0) = to c0 cs0 - where - go :: ByteString -> P.ByteString -> ByteString -> ByteString - go Empty c' cs' = to c' cs' - go (Chunk c cs) c' cs' = Chunk c (go cs c' cs') - - to :: P.ByteString -> ByteString -> ByteString - to c cs | S.null c = case cs of - Empty -> Empty - (Chunk c' cs') -> to c' cs' - | otherwise = go (f (S.unsafeHead c)) (S.unsafeTail c) cs - --- | /O(n)/ Applied to a predicate and a ByteString, 'any' determines if --- any element of the 'ByteString' satisfies the predicate. -any :: (Word8 -> Bool) -> ByteString -> Bool -any f cs = foldrChunks (\c rest -> S.any f c || rest) False cs -{-# INLINE any #-} --- todo fuse - --- | /O(n)/ Applied to a predicate and a 'ByteString', 'all' determines --- if all elements of the 'ByteString' satisfy the predicate. -all :: (Word8 -> Bool) -> ByteString -> Bool -all f cs = foldrChunks (\c rest -> S.all f c && rest) True cs -{-# INLINE all #-} --- todo fuse - --- | /O(n)/ 'maximum' returns the maximum value from a 'ByteString' -maximum :: ByteString -> Word8 -maximum Empty = errorEmptyList "maximum" -maximum (Chunk c cs) = foldlChunks (\n c' -> n `max` S.maximum c') - (S.maximum c) cs -{-# INLINE maximum #-} - --- | /O(n)/ 'minimum' returns the minimum value from a 'ByteString' -minimum :: ByteString -> Word8 -minimum Empty = errorEmptyList "minimum" -minimum (Chunk c cs) = foldlChunks (\n c' -> n `min` S.minimum c') - (S.minimum c) cs -{-# INLINE minimum #-} - --- | The 'mapAccumL' function behaves like a combination of 'map' and --- 'foldl'; it applies a function to each element of a ByteString, --- passing an accumulating parameter from left to right, and returning a --- final value of this accumulator together with the new ByteString. -mapAccumL :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) -mapAccumL f s0 cs0 = go s0 cs0 - where - go s Empty = (s, Empty) - go s (Chunk c cs) = (s'', Chunk c' cs') - where (s', c') = S.mapAccumL f s c - (s'', cs') = go s' cs - --- | The 'mapAccumR' function behaves like a combination of 'map' and --- 'foldr'; it applies a function to each element of a ByteString, --- passing an accumulating parameter from right to left, and returning a --- final value of this accumulator together with the new ByteString. -mapAccumR :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) -mapAccumR f s0 cs0 = go s0 cs0 - where - go s Empty = (s, Empty) - go s (Chunk c cs) = (s'', Chunk c' cs') - where (s'', c') = S.mapAccumR f s' c - (s', cs') = go s cs - --- --------------------------------------------------------------------- --- Building ByteStrings - --- | 'scanl' is similar to 'foldl', but returns a list of successive --- reduced values from the left. This function will fuse. --- --- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] --- --- Note that --- --- > last (scanl f z xs) == foldl f z xs. -scanl :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString -scanl f z = snd . foldl k (z,singleton z) - where - k (c,acc) a = let n = f c a in (n, acc `snoc` n) -{-# INLINE scanl #-} - --- --------------------------------------------------------------------- --- Unfolds and replicates - --- | @'iterate' f x@ returns an infinite ByteString of repeated applications --- of @f@ to @x@: --- --- > iterate f x == [x, f x, f (f x), ...] --- -iterate :: (Word8 -> Word8) -> Word8 -> ByteString -iterate f = unfoldr (\x -> case f x of x' -> x' `seq` Just (x', x')) - --- | @'repeat' x@ is an infinite ByteString, with @x@ the value of every --- element. --- -repeat :: Word8 -> ByteString -repeat w = cs where cs = Chunk (S.replicate smallChunkSize w) cs - --- | /O(n)/ @'replicate' n x@ is a ByteString of length @n@ with @x@ --- the value of every element. --- -replicate :: Int64 -> Word8 -> ByteString -replicate n w - | n <= 0 = Empty - | n < fromIntegral smallChunkSize = Chunk (S.replicate (fromIntegral n) w) Empty - | r == 0 = cs -- preserve invariant - | otherwise = Chunk (S.unsafeTake (fromIntegral r) c) cs - where - c = S.replicate smallChunkSize w - cs = nChunks q - (q, r) = quotRem n (fromIntegral smallChunkSize) - nChunks 0 = Empty - nChunks m = Chunk c (nChunks (m-1)) - --- | 'cycle' ties a finite ByteString into a circular one, or equivalently, --- the infinite repetition of the original ByteString. --- -cycle :: ByteString -> ByteString -cycle Empty = errorEmptyList "cycle" -cycle cs = cs' where cs' = foldrChunks Chunk cs' cs - --- | /O(n)/ The 'unfoldr' function is analogous to the List \'unfoldr\'. --- 'unfoldr' builds a ByteString from a seed value. The function takes --- the element and returns 'Nothing' if it is done producing the --- ByteString or returns 'Just' @(a,b)@, in which case, @a@ is a --- prepending to the ByteString and @b@ is used as the next element in a --- recursive call. -unfoldr :: (a -> Maybe (Word8, a)) -> a -> ByteString -unfoldr f s0 = unfoldChunk 32 s0 - where unfoldChunk n s = - case S.unfoldrN n f s of - (c, Nothing) - | S.null c -> Empty - | otherwise -> Chunk c Empty - (c, Just s') -> Chunk c (unfoldChunk (n*2) s') - --- --------------------------------------------------------------------- --- Substrings - --- | /O(n\/c)/ 'take' @n@, applied to a ByteString @xs@, returns the prefix --- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. -take :: Int64 -> ByteString -> ByteString -take i _ | i <= 0 = Empty -take i cs0 = take' i cs0 - where take' 0 _ = Empty - take' _ Empty = Empty - take' n (Chunk c cs) = - if n < fromIntegral (S.length c) - then Chunk (S.take (fromIntegral n) c) Empty - else Chunk c (take' (n - fromIntegral (S.length c)) cs) - --- | /O(n\/c)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ --- elements, or @[]@ if @n > 'length' xs@. -drop :: Int64 -> ByteString -> ByteString -drop i p | i <= 0 = p -drop i cs0 = drop' i cs0 - where drop' 0 cs = cs - drop' _ Empty = Empty - drop' n (Chunk c cs) = - if n < fromIntegral (S.length c) - then Chunk (S.drop (fromIntegral n) c) cs - else drop' (n - fromIntegral (S.length c)) cs - --- | /O(n\/c)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@. -splitAt :: Int64 -> ByteString -> (ByteString, ByteString) -splitAt i cs0 | i <= 0 = (Empty, cs0) -splitAt i cs0 = splitAt' i cs0 - where splitAt' 0 cs = (Empty, cs) - splitAt' _ Empty = (Empty, Empty) - splitAt' n (Chunk c cs) = - if n < fromIntegral (S.length c) - then (Chunk (S.take (fromIntegral n) c) Empty - ,Chunk (S.drop (fromIntegral n) c) cs) - else let (cs', cs'') = splitAt' (n - fromIntegral (S.length c)) cs - in (Chunk c cs', cs'') - - --- | 'takeWhile', applied to a predicate @p@ and a ByteString @xs@, --- returns the longest prefix (possibly empty) of @xs@ of elements that --- satisfy @p@. -takeWhile :: (Word8 -> Bool) -> ByteString -> ByteString -takeWhile f cs0 = takeWhile' cs0 - where takeWhile' Empty = Empty - takeWhile' (Chunk c cs) = - case findIndexOrEnd (not . f) c of - 0 -> Empty - n | n < S.length c -> Chunk (S.take n c) Empty - | otherwise -> Chunk c (takeWhile' cs) - --- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@. -dropWhile :: (Word8 -> Bool) -> ByteString -> ByteString -dropWhile f cs0 = dropWhile' cs0 - where dropWhile' Empty = Empty - dropWhile' (Chunk c cs) = - case findIndexOrEnd (not . f) c of - n | n < S.length c -> Chunk (S.drop n c) cs - | otherwise -> dropWhile' cs - --- | 'break' @p@ is equivalent to @'span' ('not' . p)@. -break :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) -break f cs0 = break' cs0 - where break' Empty = (Empty, Empty) - break' (Chunk c cs) = - case findIndexOrEnd f c of - 0 -> (Empty, Chunk c cs) - n | n < S.length c -> (Chunk (S.take n c) Empty - ,Chunk (S.drop n c) cs) - | otherwise -> let (cs', cs'') = break' cs - in (Chunk c cs', cs'') - --- --- TODO --- --- Add rules --- - -{- --- | 'breakByte' breaks its ByteString argument at the first occurence --- of the specified byte. It is more efficient than 'break' as it is --- implemented with @memchr(3)@. I.e. --- --- > break (=='c') "abcd" == breakByte 'c' "abcd" --- -breakByte :: Word8 -> ByteString -> (ByteString, ByteString) -breakByte c (LPS ps) = case (breakByte' ps) of (a,b) -> (LPS a, LPS b) - where breakByte' [] = ([], []) - breakByte' (x:xs) = - case P.elemIndex c x of - Just 0 -> ([], x : xs) - Just n -> (P.take n x : [], P.drop n x : xs) - Nothing -> let (xs', xs'') = breakByte' xs - in (x : xs', xs'') - --- | 'spanByte' breaks its ByteString argument at the first --- occurence of a byte other than its argument. It is more efficient --- than 'span (==)' --- --- > span (=='c') "abcd" == spanByte 'c' "abcd" --- -spanByte :: Word8 -> ByteString -> (ByteString, ByteString) -spanByte c (LPS ps) = case (spanByte' ps) of (a,b) -> (LPS a, LPS b) - where spanByte' [] = ([], []) - spanByte' (x:xs) = - case P.spanByte c x of - (x', x'') | P.null x' -> ([], x : xs) - | P.null x'' -> let (xs', xs'') = spanByte' xs - in (x : xs', xs'') - | otherwise -> (x' : [], x'' : xs) --} - --- | 'span' @p xs@ breaks the ByteString into two segments. It is --- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@ -span :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) -span p = break (not . p) - --- | /O(n)/ Splits a 'ByteString' into components delimited by --- separators, where the predicate returns True for a separator element. --- The resulting components do not contain the separators. Two adjacent --- separators result in an empty component in the output. eg. --- --- > splitWith (=='a') "aabbaca" == ["","","bb","c",""] --- > splitWith (=='a') [] == [] --- -splitWith :: (Word8 -> Bool) -> ByteString -> [ByteString] -splitWith _ Empty = [] -splitWith p (Chunk c0 cs0) = comb [] (S.splitWith p c0) cs0 - - where comb :: [P.ByteString] -> [P.ByteString] -> ByteString -> [ByteString] - comb acc (s:[]) Empty = revChunks (s:acc) : [] - comb acc (s:[]) (Chunk c cs) = comb (s:acc) (S.splitWith p c) cs - comb acc (s:ss) cs = revChunks (s:acc) : comb [] ss cs - -{-# INLINE splitWith #-} - --- | /O(n)/ Break a 'ByteString' into pieces separated by the byte --- argument, consuming the delimiter. I.e. --- --- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"] --- > split 'a' "aXaXaXa" == ["","X","X","X",""] --- > split 'x' "x" == ["",""] --- --- and --- --- > intercalate [c] . split c == id --- > split == splitWith . (==) --- --- As for all splitting functions in this library, this function does --- not copy the substrings, it just constructs new 'ByteStrings' that --- are slices of the original. --- -split :: Word8 -> ByteString -> [ByteString] -split _ Empty = [] -split w (Chunk c0 cs0) = comb [] (S.split w c0) cs0 - - where comb :: [P.ByteString] -> [P.ByteString] -> ByteString -> [ByteString] - comb acc (s:[]) Empty = revChunks (s:acc) : [] - comb acc (s:[]) (Chunk c cs) = comb (s:acc) (S.split w c) cs - comb acc (s:ss) cs = revChunks (s:acc) : comb [] ss cs -{-# INLINE split #-} - -{- --- | Like 'splitWith', except that sequences of adjacent separators are --- treated as a single separator. eg. --- --- > tokens (=='a') "aabbaca" == ["bb","c"] --- -tokens :: (Word8 -> Bool) -> ByteString -> [ByteString] -tokens f = L.filter (not.null) . splitWith f --} - --- | The 'group' function takes a ByteString and returns a list of --- ByteStrings such that the concatenation of the result is equal to the --- argument. Moreover, each sublist in the result contains only equal --- elements. For example, --- --- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"] --- --- It is a special case of 'groupBy', which allows the programmer to --- supply their own equality test. -group :: ByteString -> [ByteString] -group = go - where - go Empty = [] - go (Chunk c cs) - | S.length c == 1 = to [c] (S.unsafeHead c) cs - | otherwise = to [S.unsafeTake 1 c] (S.unsafeHead c) (Chunk (S.unsafeTail c) cs) - - to acc !_ Empty = revNonEmptyChunks acc : [] - to acc !w (Chunk c cs) = - case findIndexOrEnd (/= w) c of - 0 -> revNonEmptyChunks acc - : go (Chunk c cs) - n | n == S.length c -> to (S.unsafeTake n c : acc) w cs - | otherwise -> revNonEmptyChunks (S.unsafeTake n c : acc) - : go (Chunk (S.unsafeDrop n c) cs) - --- | The 'groupBy' function is the non-overloaded version of 'group'. --- -groupBy :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString] -groupBy k = go - where - go Empty = [] - go (Chunk c cs) - | S.length c == 1 = to [c] (S.unsafeHead c) cs - | otherwise = to [S.unsafeTake 1 c] (S.unsafeHead c) (Chunk (S.unsafeTail c) cs) - - to acc !_ Empty = revNonEmptyChunks acc : [] - to acc !w (Chunk c cs) = - case findIndexOrEnd (not . k w) c of - 0 -> revNonEmptyChunks acc - : go (Chunk c cs) - n | n == S.length c -> to (S.unsafeTake n c : acc) w cs - | otherwise -> revNonEmptyChunks (S.unsafeTake n c : acc) - : go (Chunk (S.unsafeDrop n c) cs) - --- | /O(n)/ The 'intercalate' function takes a 'ByteString' and a list of --- 'ByteString's and concatenates the list after interspersing the first --- argument between each element of the list. -intercalate :: ByteString -> [ByteString] -> ByteString -intercalate s = concat . (L.intersperse s) - --- --------------------------------------------------------------------- --- Indexing ByteStrings - --- | /O(c)/ 'ByteString' index (subscript) operator, starting from 0. -index :: ByteString -> Int64 -> Word8 -index _ i | i < 0 = moduleError "index" ("negative index: " ++ show i) -index cs0 i = index' cs0 i - where index' Empty n = moduleError "index" ("index too large: " ++ show n) - index' (Chunk c cs) n - | n >= fromIntegral (S.length c) = - index' cs (n - fromIntegral (S.length c)) - | otherwise = S.unsafeIndex c (fromIntegral n) - --- | /O(n)/ The 'elemIndex' function returns the index of the first --- element in the given 'ByteString' which is equal to the query --- element, or 'Nothing' if there is no such element. --- This implementation uses memchr(3). -elemIndex :: Word8 -> ByteString -> Maybe Int64 -elemIndex w cs0 = elemIndex' 0 cs0 - where elemIndex' _ Empty = Nothing - elemIndex' n (Chunk c cs) = - case S.elemIndex w c of - Nothing -> elemIndex' (n + fromIntegral (S.length c)) cs - Just i -> Just (n + fromIntegral i) - -{- --- | /O(n)/ The 'elemIndexEnd' function returns the last index of the --- element in the given 'ByteString' which is equal to the query --- element, or 'Nothing' if there is no such element. The following --- holds: --- --- > elemIndexEnd c xs == --- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs) --- -elemIndexEnd :: Word8 -> ByteString -> Maybe Int -elemIndexEnd ch (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> - go (p `plusPtr` s) (l-1) - where - STRICT2(go) - go p i | i < 0 = return Nothing - | otherwise = do ch' <- peekByteOff p i - if ch == ch' - then return $ Just i - else go p (i-1) --} --- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning --- the indices of all elements equal to the query element, in ascending order. --- This implementation uses memchr(3). -elemIndices :: Word8 -> ByteString -> [Int64] -elemIndices w cs0 = elemIndices' 0 cs0 - where elemIndices' _ Empty = [] - elemIndices' n (Chunk c cs) = L.map ((+n).fromIntegral) (S.elemIndices w c) - ++ elemIndices' (n + fromIntegral (S.length c)) cs - --- | count returns the number of times its argument appears in the ByteString --- --- > count = length . elemIndices --- --- But more efficiently than using length on the intermediate list. -count :: Word8 -> ByteString -> Int64 -count w cs = foldlChunks (\n c -> n + fromIntegral (S.count w c)) 0 cs - --- | The 'findIndex' function takes a predicate and a 'ByteString' and --- returns the index of the first element in the ByteString --- satisfying the predicate. -findIndex :: (Word8 -> Bool) -> ByteString -> Maybe Int64 -findIndex k cs0 = findIndex' 0 cs0 - where findIndex' _ Empty = Nothing - findIndex' n (Chunk c cs) = - case S.findIndex k c of - Nothing -> findIndex' (n + fromIntegral (S.length c)) cs - Just i -> Just (n + fromIntegral i) -{-# INLINE findIndex #-} - --- | /O(n)/ The 'find' function takes a predicate and a ByteString, --- and returns the first element in matching the predicate, or 'Nothing' --- if there is no such element. --- --- > find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing --- -find :: (Word8 -> Bool) -> ByteString -> Maybe Word8 -find f cs0 = find' cs0 - where find' Empty = Nothing - find' (Chunk c cs) = case S.find f c of - Nothing -> find' cs - Just w -> Just w -{-# INLINE find #-} - --- | The 'findIndices' function extends 'findIndex', by returning the --- indices of all elements satisfying the predicate, in ascending order. -findIndices :: (Word8 -> Bool) -> ByteString -> [Int64] -findIndices k cs0 = findIndices' 0 cs0 - where findIndices' _ Empty = [] - findIndices' n (Chunk c cs) = L.map ((+n).fromIntegral) (S.findIndices k c) - ++ findIndices' (n + fromIntegral (S.length c)) cs - --- --------------------------------------------------------------------- --- Searching ByteStrings - --- | /O(n)/ 'elem' is the 'ByteString' membership predicate. -elem :: Word8 -> ByteString -> Bool -elem w cs = case elemIndex w cs of Nothing -> False ; _ -> True - --- | /O(n)/ 'notElem' is the inverse of 'elem' -notElem :: Word8 -> ByteString -> Bool -notElem w cs = not (elem w cs) - --- | /O(n)/ 'filter', applied to a predicate and a ByteString, --- returns a ByteString containing those characters that satisfy the --- predicate. -filter :: (Word8 -> Bool) -> ByteString -> ByteString -filter p s = go s - where - go Empty = Empty - go (Chunk x xs) = chunk (S.filter p x) (go xs) -{-# INLINE filter #-} - -{- --- | /O(n)/ and /O(n\/c) space/ A first order equivalent of /filter . --- (==)/, for the common case of filtering a single byte. It is more --- efficient to use /filterByte/ in this case. --- --- > filterByte == filter . (==) --- --- filterByte is around 10x faster, and uses much less space, than its --- filter equivalent -filterByte :: Word8 -> ByteString -> ByteString -filterByte w ps = replicate (count w ps) w -{-# INLINE filterByte #-} - -{-# RULES -"ByteString specialise filter (== x)" forall x. - filter ((==) x) = filterByte x - -"ByteString specialise filter (== x)" forall x. - filter (== x) = filterByte x - #-} --} - -{- --- | /O(n)/ A first order equivalent of /filter . (\/=)/, for the common --- case of filtering a single byte out of a list. It is more efficient --- to use /filterNotByte/ in this case. --- --- > filterNotByte == filter . (/=) --- --- filterNotByte is around 2x faster than its filter equivalent. -filterNotByte :: Word8 -> ByteString -> ByteString -filterNotByte w (LPS xs) = LPS (filterMap (P.filterNotByte w) xs) --} - --- | /O(n)/ The 'partition' function takes a predicate a ByteString and returns --- the pair of ByteStrings with elements which do and do not satisfy the --- predicate, respectively; i.e., --- --- > partition p bs == (filter p xs, filter (not . p) xs) --- -partition :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) -partition f p = (filter f p, filter (not . f) p) ---TODO: use a better implementation - --- --------------------------------------------------------------------- --- Searching for substrings - --- | /O(n)/ The 'isPrefixOf' function takes two ByteStrings and returns 'True' --- iff the first is a prefix of the second. -isPrefixOf :: ByteString -> ByteString -> Bool -isPrefixOf Empty _ = True -isPrefixOf _ Empty = False -isPrefixOf (Chunk x xs) (Chunk y ys) - | S.length x == S.length y = x == y && isPrefixOf xs ys - | S.length x < S.length y = x == yh && isPrefixOf xs (Chunk yt ys) - | otherwise = xh == y && isPrefixOf (Chunk xt xs) ys - where (xh,xt) = S.splitAt (S.length y) x - (yh,yt) = S.splitAt (S.length x) y - --- | /O(n)/ The 'isSuffixOf' function takes two ByteStrings and returns 'True' --- iff the first is a suffix of the second. --- --- The following holds: --- --- > isSuffixOf x y == reverse x `isPrefixOf` reverse y --- -isSuffixOf :: ByteString -> ByteString -> Bool -isSuffixOf x y = reverse x `isPrefixOf` reverse y ---TODO: a better implementation - --- --------------------------------------------------------------------- --- Zipping - --- | /O(n)/ 'zip' takes two ByteStrings and returns a list of --- corresponding pairs of bytes. If one input ByteString is short, --- excess elements of the longer ByteString are discarded. This is --- equivalent to a pair of 'unpack' operations. -zip :: ByteString -> ByteString -> [(Word8,Word8)] -zip = zipWith (,) - --- | 'zipWith' generalises 'zip' by zipping with the function given as --- the first argument, instead of a tupling function. For example, --- @'zipWith' (+)@ is applied to two ByteStrings to produce the list of --- corresponding sums. -zipWith :: (Word8 -> Word8 -> a) -> ByteString -> ByteString -> [a] -zipWith _ Empty _ = [] -zipWith _ _ Empty = [] -zipWith f (Chunk a as) (Chunk b bs) = go a as b bs - where - go x xs y ys = f (S.unsafeHead x) (S.unsafeHead y) - : to (S.unsafeTail x) xs (S.unsafeTail y) ys - - to x Empty _ _ | S.null x = [] - to _ _ y Empty | S.null y = [] - to x xs y ys | not (S.null x) - && not (S.null y) = go x xs y ys - to x xs _ (Chunk y' ys) | not (S.null x) = go x xs y' ys - to _ (Chunk x' xs) y ys | not (S.null y) = go x' xs y ys - to _ (Chunk x' xs) _ (Chunk y' ys) = go x' xs y' ys - --- | /O(n)/ 'unzip' transforms a list of pairs of bytes into a pair of --- ByteStrings. Note that this performs two 'pack' operations. -unzip :: [(Word8,Word8)] -> (ByteString,ByteString) -unzip ls = (pack (L.map fst ls), pack (L.map snd ls)) -{-# INLINE unzip #-} - --- --------------------------------------------------------------------- --- Special lists - --- | /O(n)/ Return all initial segments of the given 'ByteString', shortest first. -inits :: ByteString -> [ByteString] -inits = (Empty :) . inits' - where inits' Empty = [] - inits' (Chunk c cs) = L.map (\c' -> Chunk c' Empty) (L.tail (S.inits c)) - ++ L.map (Chunk c) (inits' cs) - --- | /O(n)/ Return all final segments of the given 'ByteString', longest first. -tails :: ByteString -> [ByteString] -tails Empty = Empty : [] -tails cs@(Chunk c cs') - | S.length c == 1 = cs : tails cs' - | otherwise = cs : tails (Chunk (S.unsafeTail c) cs') - --- --------------------------------------------------------------------- --- Low level constructors - --- | /O(n)/ Make a copy of the 'ByteString' with its own storage. --- This is mainly useful to allow the rest of the data pointed --- to by the 'ByteString' to be garbage collected, for example --- if a large string has been read in, and only a small part of it --- is needed in the rest of the program. -copy :: ByteString -> ByteString -copy cs = foldrChunks (Chunk . S.copy) Empty cs ---TODO, we could coalese small blocks here ---FIXME: probably not strict enough, if we're doing this to avoid retaining --- the parent blocks then we'd better copy strictly. - --- --------------------------------------------------------------------- - --- TODO defrag func that concatenates block together that are below a threshold --- defrag :: ByteString -> ByteString - --- --------------------------------------------------------------------- --- Lazy ByteString IO --- --- Rule for when to close: is it expected to read the whole file? --- If so, close when done. --- - --- | Read entire handle contents /lazily/ into a 'ByteString'. Chunks --- are read on demand, in at most @k@-sized chunks. It does not block --- waiting for a whole @k@-sized chunk, so if less than @k@ bytes are --- available then they will be returned immediately as a smaller chunk. --- --- The handle is closed on EOF. --- --- Note: the 'Handle' should be placed in binary mode with --- 'System.IO.hSetBinaryMode' for 'hGetContentsN' to --- work correctly. --- -hGetContentsN :: Int -> Handle -> IO ByteString -hGetContentsN k h = lazyRead -- TODO close on exceptions - where - lazyRead = unsafeInterleaveIO loop - - loop = do - c <- S.hGetSome h k -- only blocks if there is no data available - if S.null c - then do hClose h >> return Empty - else do cs <- lazyRead - return (Chunk c cs) - --- | Read @n@ bytes into a 'ByteString', directly from the --- specified 'Handle', in chunks of size @k@. --- -hGetN :: Int -> Handle -> Int -> IO ByteString -hGetN k h n | n > 0 = readChunks n - where - STRICT1(readChunks) - readChunks i = do - c <- S.hGet h (min k i) - case S.length c of - 0 -> return Empty - m -> do cs <- readChunks (i - m) - return (Chunk c cs) - -hGetN _ _ 0 = return Empty -hGetN _ h n = illegalBufferSize h "hGet" n - --- | hGetNonBlockingN is similar to 'hGetContentsN', except that it will never block --- waiting for data to become available, instead it returns only whatever data --- is available. Chunks are read on demand, in @k@-sized chunks. --- -hGetNonBlockingN :: Int -> Handle -> Int -> IO ByteString -#if defined(__GLASGOW_HASKELL__) -hGetNonBlockingN k h n | n > 0= readChunks n - where - STRICT1(readChunks) - readChunks i = do - c <- S.hGetNonBlocking h (min k i) - case S.length c of - 0 -> return Empty - m -> do cs <- readChunks (i - m) - return (Chunk c cs) - -hGetNonBlockingN _ _ 0 = return Empty -hGetNonBlockingN _ h n = illegalBufferSize h "hGetNonBlocking" n -#else -hGetNonBlockingN = hGetN -#endif - -illegalBufferSize :: Handle -> String -> Int -> IO a -illegalBufferSize handle fn sz = - ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing) - --TODO: System.IO uses InvalidArgument here, but it's not exported :-( - where - msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz [] - --- | Read entire handle contents /lazily/ into a 'ByteString'. Chunks --- are read on demand, using the default chunk size. --- --- Once EOF is encountered, the Handle is closed. --- --- Note: the 'Handle' should be placed in binary mode with --- 'System.IO.hSetBinaryMode' for 'hGetContents' to --- work correctly. --- -hGetContents :: Handle -> IO ByteString -hGetContents = hGetContentsN defaultChunkSize - --- | Read @n@ bytes into a 'ByteString', directly from the specified 'Handle'. --- -hGet :: Handle -> Int -> IO ByteString -hGet = hGetN defaultChunkSize - --- | hGetNonBlocking is similar to 'hGet', except that it will never block --- waiting for data to become available, instead it returns only whatever data --- is available. If there is no data available to be read, 'hGetNonBlocking' --- returns 'empty'. --- --- Note: on Windows and with Haskell implementation other than GHC, this --- function does not work correctly; it behaves identically to 'hGet'. --- -#if defined(__GLASGOW_HASKELL__) -hGetNonBlocking :: Handle -> Int -> IO ByteString -hGetNonBlocking = hGetNonBlockingN defaultChunkSize -#else -hGetNonBlocking = hGet -#endif - --- | Read an entire file /lazily/ into a 'ByteString'. --- The Handle will be held open until EOF is encountered. --- -readFile :: FilePath -> IO ByteString -readFile f = openBinaryFile f ReadMode >>= hGetContents - --- | Write a 'ByteString' to a file. --- -writeFile :: FilePath -> ByteString -> IO () -writeFile f txt = bracket (openBinaryFile f WriteMode) hClose - (\hdl -> hPut hdl txt) - --- | Append a 'ByteString' to a file. --- -appendFile :: FilePath -> ByteString -> IO () -appendFile f txt = bracket (openBinaryFile f AppendMode) hClose - (\hdl -> hPut hdl txt) - --- | getContents. Equivalent to hGetContents stdin. Will read /lazily/ --- -getContents :: IO ByteString -getContents = hGetContents stdin - --- | Outputs a 'ByteString' to the specified 'Handle'. --- -hPut :: Handle -> ByteString -> IO () -hPut h cs = foldrChunks (\c rest -> S.hPut h c >> rest) (return ()) cs - --- | Similar to 'hPut' except that it will never block. Instead it returns --- any tail that did not get written. This tail may be 'empty' in the case that --- the whole string was written, or the whole original string if nothing was --- written. Partial writes are also possible. --- --- Note: on Windows and with Haskell implementation other than GHC, this --- function does not work correctly; it behaves identically to 'hPut'. --- -hPutNonBlocking :: Handle -> ByteString -> IO ByteString -hPutNonBlocking _ Empty = return Empty -hPutNonBlocking h bs@(Chunk c cs) = do - c' <- S.hPutNonBlocking h c - case S.length c' of - l' | l' == S.length c -> hPutNonBlocking h cs - 0 -> return bs - _ -> return (Chunk c' cs) - --- | A synonym for @hPut@, for compatibility --- -hPutStr :: Handle -> ByteString -> IO () -hPutStr = hPut - --- | Write a ByteString to stdout -putStr :: ByteString -> IO () -putStr = hPut stdout - --- | Write a ByteString to stdout, appending a newline byte --- -putStrLn :: ByteString -> IO () -putStrLn ps = hPut stdout ps >> hPut stdout (singleton 0x0a) - -{-# DEPRECATED putStrLn - "Use Data.ByteString.Lazy.Char8.putStrLn instead. (Functions that rely on ASCII encodings belong in Data.ByteString.Lazy.Char8)" - #-} - --- | The interact function takes a function of type @ByteString -> ByteString@ --- as its argument. The entire input from the standard input device is passed --- to this function as its argument, and the resulting string is output on the --- standard output device. --- -interact :: (ByteString -> ByteString) -> IO () -interact transformer = putStr . transformer =<< getContents - --- --------------------------------------------------------------------- --- Internal utilities - --- Common up near identical calls to `error' to reduce the number --- constant strings created when compiled: -errorEmptyList :: String -> a -errorEmptyList fun = moduleError fun "empty ByteString" -{-# NOINLINE errorEmptyList #-} - -moduleError :: String -> String -> a -moduleError fun msg = error ("Data.ByteString.Lazy." ++ fun ++ ':':' ':msg) -{-# NOINLINE moduleError #-} - - --- reverse a list of non-empty chunks into a lazy ByteString -revNonEmptyChunks :: [P.ByteString] -> ByteString -revNonEmptyChunks cs = L.foldl' (flip Chunk) Empty cs - --- reverse a list of possibly-empty chunks into a lazy ByteString -revChunks :: [P.ByteString] -> ByteString -revChunks cs = L.foldl' (flip chunk) Empty cs - --- | 'findIndexOrEnd' is a variant of findIndex, that returns the length --- of the string if no element is found, rather than Nothing. -findIndexOrEnd :: (Word8 -> Bool) -> P.ByteString -> Int -findIndexOrEnd k (S.PS x s l) = S.inlinePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0 - where - STRICT2(go) - go ptr n | n >= l = return l - | otherwise = do w <- peek ptr - if k w - then return n - else go (ptr `plusPtr` 1) (n+1) -{-# INLINE findIndexOrEnd #-} +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_HADDOCK prune #-} + +-- | +-- Module : Data.ByteString.Lazy +-- Copyright : (c) Don Stewart 2006 +-- (c) Duncan Coutts 2006-2011 +-- License : BSD-style +-- +-- Maintainer : dons00@gmail.com, duncan@community.haskell.org +-- Stability : stable +-- Portability : portable +-- +-- A time and space-efficient implementation of lazy byte vectors +-- using lists of packed 'Word8' arrays, suitable for high performance +-- use, both in terms of large data quantities, or high speed +-- requirements. Lazy ByteStrings are encoded as lazy lists of strict chunks +-- of bytes. +-- +-- A key feature of lazy ByteStrings is the means to manipulate large or +-- unbounded streams of data without requiring the entire sequence to be +-- resident in memory. To take advantage of this you have to write your +-- functions in a lazy streaming style, e.g. classic pipeline composition. The +-- default I\/O chunk size is 32k, which should be good in most circumstances. +-- +-- Some operations, such as 'concat', 'append', 'reverse' and 'cons', have +-- better complexity than their "Data.ByteString" equivalents, due to +-- optimisations resulting from the list spine structure. For other +-- operations lazy ByteStrings are usually within a few percent of +-- strict ones. +-- +-- The recomended way to assemble lazy ByteStrings from smaller parts +-- is to use the builder monoid from "Data.ByteString.Builder". +-- +-- This module is intended to be imported @qualified@, to avoid name +-- clashes with "Prelude" functions. eg. +-- +-- > import qualified Data.ByteString.Lazy as B +-- +-- Original GHC implementation by Bryan O\'Sullivan. +-- Rewritten to use 'Data.Array.Unboxed.UArray' by Simon Marlow. +-- Rewritten to support slices and use 'Foreign.ForeignPtr.ForeignPtr' +-- by David Roundy. +-- Rewritten again and extended by Don Stewart and Duncan Coutts. +-- Lazy variant by Duncan Coutts and Don Stewart. +-- + +module Data.ByteString.Lazy ( + + -- * Lazy @ByteString@ + ByteString, + LazyByteString, + + -- * Introducing and eliminating 'ByteString's + empty, + singleton, + pack, + unpack, + fromStrict, + toStrict, + fromChunks, + toChunks, + foldrChunks, + foldlChunks, + + -- * Basic interface + cons, + cons', + snoc, + append, + head, + uncons, + unsnoc, + last, + tail, + init, + null, + length, + + -- * Transforming ByteStrings + map, + reverse, + intersperse, + intercalate, + transpose, + + -- * Reducing 'ByteString's (folds) + foldl, + foldl', + foldl1, + foldl1', + foldr, + foldr', + foldr1, + foldr1', + + -- ** Special folds + concat, + concatMap, + any, + all, + maximum, + minimum, + compareLength, + + -- * Building ByteStrings + -- ** Scans + scanl, + scanl1, + scanr, + scanr1, + + -- ** Accumulating maps + mapAccumL, + mapAccumR, + + -- ** Infinite ByteStrings + repeat, + replicate, + cycle, + iterate, + + -- ** Unfolding ByteStrings + unfoldr, + + -- * Substrings + + -- ** Breaking strings + take, + takeEnd, + drop, + dropEnd, + splitAt, + takeWhile, + takeWhileEnd, + dropWhile, + dropWhileEnd, + span, + spanEnd, + break, + breakEnd, + group, + groupBy, + inits, + tails, + initsNE, + tailsNE, + stripPrefix, + stripSuffix, + + -- ** Breaking into many substrings + split, + splitWith, + + -- * Predicates + isPrefixOf, + isSuffixOf, +-- isInfixOf, + + -- ** Search for arbitrary substrings +-- isSubstringOf, + + -- * Searching ByteStrings + + -- ** Searching by equality + elem, + notElem, + + -- ** Searching with a predicate + find, + filter, + partition, + + -- * Indexing ByteStrings + index, + indexMaybe, + (!?), + elemIndex, + elemIndexEnd, + elemIndices, + findIndex, + findIndexEnd, + findIndices, + count, + + -- * Zipping and unzipping ByteStrings + zip, + zipWith, + packZipWith, + unzip, + + -- * Ordered ByteStrings +-- sort, + + -- * Low level conversions + -- ** Copying ByteStrings + copy, +-- defrag, + + -- * I\/O with 'ByteString's + -- $IOChunk + + -- ** Standard input and output + getContents, + putStr, + interact, + + -- ** Files + readFile, + writeFile, + appendFile, + + -- ** I\/O with Handles + hGetContents, + hGet, + hGetNonBlocking, + hPut, + hPutNonBlocking, + hPutStr, + + ) where + +import Prelude hiding + (reverse,head,tail,last,init,Foldable(..),map,lines,unlines + ,concat,any,take,drop,splitAt,takeWhile,dropWhile,span,break,filter + ,all,concatMap,scanl, scanl1, scanr, scanr1 + ,repeat, cycle, interact, iterate,readFile,writeFile,appendFile,replicate + ,getContents,getLine,putStr,putStrLn ,zip,zipWith,unzip,notElem) + +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Bifunctor as BF +import qualified Data.ByteString as P (ByteString) -- type name only +import qualified Data.ByteString as S -- S for strict (hmm...) +import qualified Data.ByteString.Internal.Type as S +import qualified Data.ByteString.Unsafe as S +import Data.ByteString.Lazy.Internal + +import Control.Exception (assert) +import Control.Monad (mplus) +import Data.Word (Word8) +import Data.Int (Int64) +import GHC.Stack.Types (HasCallStack) +import System.IO (Handle,openBinaryFile,stdin,stdout,withBinaryFile,IOMode(..) + ,hClose) +import System.IO.Error (mkIOError, illegalOperationErrorType) +import System.IO.Unsafe + +import Foreign.Ptr +import Foreign.Storable + + +-- ----------------------------------------------------------------------------- +-- Introducing and eliminating 'ByteString's + +-- | /O(1)/ The empty 'ByteString' +empty :: ByteString +empty = Empty +{-# INLINE empty #-} + +-- | /O(1)/ Convert a 'Word8' into a 'ByteString' +singleton :: Word8 -> ByteString +singleton w = Chunk (S.singleton w) Empty +{-# INLINE singleton #-} + +-- | /O(n)/ Convert a '[Word8]' into a 'ByteString'. +pack :: [Word8] -> ByteString +pack = packBytes + +-- | /O(n)/ Converts a 'ByteString' to a '[Word8]'. +unpack :: ByteString -> [Word8] +unpack = unpackBytes + +-- | /O(c)/ Convert a list of 'S.StrictByteString' into a 'LazyByteString' +fromChunks :: [S.StrictByteString] -> LazyByteString +fromChunks = List.foldr chunk Empty + +-- | /O(c)/ Convert a 'LazyByteString' into a list of 'S.StrictByteString' +toChunks :: LazyByteString -> [S.StrictByteString] +toChunks = foldrChunks (:) [] + +------------------------------------------------------------------------ + +{- +-- | /O(n)/ Convert a '[a]' into a 'ByteString' using some +-- conversion function +packWith :: (a -> Word8) -> [a] -> ByteString +packWith k str = LPS $ L.map (P.packWith k) (chunk defaultChunkSize str) +{-# INLINE packWith #-} +{-# SPECIALIZE packWith :: (Char -> Word8) -> [Char] -> ByteString #-} + +-- | /O(n)/ Converts a 'ByteString' to a '[a]', using a conversion function. +unpackWith :: (Word8 -> a) -> ByteString -> [a] +unpackWith k (LPS ss) = L.concatMap (S.unpackWith k) ss +{-# INLINE unpackWith #-} +{-# SPECIALIZE unpackWith :: (Word8 -> Char) -> ByteString -> [Char] #-} +-} + +-- --------------------------------------------------------------------- +-- Basic interface + +-- | /O(1)/ Test whether a ByteString is empty. +null :: ByteString -> Bool +null Empty = True +null _ = False +{-# INLINE null #-} + +-- | /O(c)/ 'length' returns the length of a ByteString as an 'Int64' +length :: ByteString -> Int64 +length = foldlChunks (\n c -> n + fromIntegral (S.length c)) 0 +{-# INLINE [1] length #-} + +infixr 5 `cons`, `cons'` --same as list (:) +infixl 5 `snoc` + +-- | /O(1)/ 'cons' is analogous to '(Prelude.:)' for lists. +-- +cons :: Word8 -> ByteString -> ByteString +cons c = Chunk (S.singleton c) +{-# INLINE cons #-} + +-- | /O(1)/ Unlike 'cons', 'cons'' is +-- strict in the ByteString that we are consing onto. More precisely, it forces +-- the head and the first chunk. It does this because, for space efficiency, it +-- may coalesce the new byte onto the first \'chunk\' rather than starting a +-- new \'chunk\'. +-- +-- So that means you can't use a lazy recursive contruction like this: +-- +-- > let xs = cons' c xs in xs +-- +-- You can however use 'cons', as well as 'repeat' and 'cycle', to build +-- infinite lazy ByteStrings. +-- +cons' :: Word8 -> ByteString -> ByteString +cons' w (Chunk c cs) | S.length c < 16 = Chunk (S.cons w c) cs +cons' w cs = Chunk (S.singleton w) cs +{-# INLINE cons' #-} + +-- | /O(n\/c)/ Append a byte to the end of a 'ByteString' +snoc :: ByteString -> Word8 -> ByteString +snoc cs w = foldrChunks Chunk (singleton w) cs +{-# INLINE snoc #-} + +-- | /O(1)/ Extract the first element of a ByteString, which must be non-empty. +-- +-- This is a partial function, consider using 'uncons' instead. +head :: HasCallStack => ByteString -> Word8 +head Empty = errorEmptyList "head" +head (Chunk c _) = S.unsafeHead c +{-# INLINE head #-} + +-- | /O(1)/ Extract the 'head' and 'tail' of a ByteString, returning 'Nothing' +-- if it is empty. +uncons :: ByteString -> Maybe (Word8, ByteString) +uncons Empty = Nothing +uncons (Chunk c cs) = case S.length c of + -- Don't move this test inside of the Just or (,). + -- We don't want to allocate a thunk to put inside of the tuple! + -- And if "let !tl = ... in Just (..., tl)" seems more appealing, + -- remember that this function must remain lazy in cs. + 1 -> Just (S.unsafeHead c, cs) + _ -> Just (S.unsafeHead c, Chunk (S.unsafeTail c) cs) +{-# INLINE uncons #-} + +-- | /O(1)/ Extract the elements after the head of a ByteString, which must be +-- non-empty. +-- +-- This is a partial function, consider using 'uncons' instead. +tail :: HasCallStack => ByteString -> ByteString +tail Empty = errorEmptyList "tail" +tail (Chunk c cs) + | S.length c == 1 = cs + | otherwise = Chunk (S.unsafeTail c) cs +{-# INLINE tail #-} + +-- | /O(n\/c)/ Extract the last element of a ByteString, which must be finite +-- and non-empty. +-- +-- This is a partial function, consider using 'unsnoc' instead. +last :: HasCallStack => ByteString -> Word8 +last Empty = errorEmptyList "last" +last (Chunk c0 cs0) = go c0 cs0 + where go c Empty = S.unsafeLast c + go _ (Chunk c cs) = go c cs +-- XXX Don't inline this. Something breaks with 6.8.2 (haven't investigated yet) + +-- | /O(n\/c)/ Returns all the elements of a 'ByteString' except the last one. +-- +-- This is a partial function, consider using 'unsnoc' instead. +init :: HasCallStack => ByteString -> ByteString +init Empty = errorEmptyList "init" +init (Chunk c0 cs0) = go c0 cs0 + where go c Empty | S.length c == 1 = Empty + | otherwise = Chunk (S.unsafeInit c) Empty + go c (Chunk c' cs) = Chunk c (go c' cs) + +-- | /O(n\/c)/ Extract the 'init' and 'last' of a ByteString, returning 'Nothing' +-- if it is empty. +-- +-- * It is no faster than using 'init' and 'last' +unsnoc :: ByteString -> Maybe (ByteString, Word8) +unsnoc Empty = Nothing +unsnoc (Chunk c cs) = Just (init (Chunk c cs), last (Chunk c cs)) + +-- | /O(n\/c)/ Append two ByteStrings +append :: ByteString -> ByteString -> ByteString +append = mappend +{-# INLINE append #-} + +-- --------------------------------------------------------------------- +-- Transformations + +-- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each +-- element of @xs@. +map :: (Word8 -> Word8) -> ByteString -> ByteString +map f = go + where + go Empty = Empty + go (Chunk x xs) = Chunk y ys + where + y = S.map f x + ys = go xs +{-# INLINE map #-} + +-- | /O(n)/ 'reverse' @xs@ returns the elements of @xs@ in reverse order. +reverse :: ByteString -> ByteString +reverse = rev Empty + where rev a Empty = a + rev a (Chunk c cs) = rev (Chunk (S.reverse c) a) cs +{-# INLINE reverse #-} + +-- | The 'intersperse' function takes a 'Word8' and a 'ByteString' and +-- \`intersperses\' that byte between the elements of the 'ByteString'. +-- It is analogous to the intersperse function on Lists. +intersperse :: Word8 -> ByteString -> ByteString +intersperse _ Empty = Empty +intersperse w (Chunk c cs) = Chunk (S.intersperse w c) + (foldrChunks (Chunk . intersperse') Empty cs) + where intersperse' :: P.ByteString -> P.ByteString + intersperse' (S.BS fp l) = + S.unsafeCreateFp (2*l) $ \fp' -> + S.unsafeWithForeignPtr fp' $ \p' -> + S.unsafeWithForeignPtr fp $ \p -> do + poke p' w + S.c_intersperse (p' `plusPtr` 1) p (fromIntegral l) w + +-- | The 'transpose' function transposes the rows and columns of its +-- 'ByteString' argument. +transpose :: [ByteString] -> [ByteString] +transpose css = List.map (\ss -> Chunk (S.pack ss) Empty) + (List.transpose (List.map unpack css)) +--TODO: make this fast + +-- --------------------------------------------------------------------- +-- Reducing 'ByteString's + +-- | 'foldl', applied to a binary operator, a starting value (typically +-- the left-identity of the operator), and a ByteString, reduces the +-- ByteString using the binary operator, from left to right. +foldl :: (a -> Word8 -> a) -> a -> ByteString -> a +foldl f = go + where go a Empty = a + go a (Chunk c cs) = go (S.foldl f a c) cs +{-# INLINE foldl #-} + +-- | 'foldl'' is like 'foldl', but strict in the accumulator. +foldl' :: (a -> Word8 -> a) -> a -> ByteString -> a +foldl' f = go + where go !a Empty = a + go !a (Chunk c cs) = go (S.foldl' f a c) cs +{-# INLINE foldl' #-} + +-- | 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a ByteString, +-- reduces the ByteString using the binary operator, from right to left. +foldr :: (Word8 -> a -> a) -> a -> ByteString -> a +foldr k = foldrChunks (flip (S.foldr k)) +{-# INLINE foldr #-} + +-- | 'foldr'' is like 'foldr', but strict in the accumulator. +-- +-- @since 0.11.2.0 +foldr' :: (Word8 -> a -> a) -> a -> ByteString -> a +foldr' f a = go + where + go Empty = a + go (Chunk c cs) = S.foldr' f (foldr' f a cs) c +{-# INLINE foldr' #-} + +-- | 'foldl1' is a variant of 'foldl' that has no starting value +-- argument, and thus must be applied to non-empty 'ByteString's. +foldl1 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldl1 _ Empty = errorEmptyList "foldl1" +foldl1 f (Chunk c cs) = go (S.unsafeHead c) (S.unsafeTail c) cs + where + go v x xs = let v' = S.foldl f v x + in case xs of + Empty -> v' + Chunk x' xs' -> go v' x' xs' + +-- | 'foldl1'' is like 'foldl1', but strict in the accumulator. +foldl1' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldl1' _ Empty = errorEmptyList "foldl1'" +foldl1' f (Chunk c cs) = go (S.unsafeHead c) (S.unsafeTail c) cs + where + go !v x xs = let v' = S.foldl' f v x + in case xs of + Empty -> v' + Chunk x' xs' -> go v' x' xs' + +-- | 'foldr1' is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty 'ByteString's +foldr1 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldr1 _ Empty = errorEmptyList "foldr1" +foldr1 f (Chunk c0 cs0) = go c0 cs0 + where go c Empty = S.foldr1 f c + go c (Chunk c' cs) = S.foldr f (go c' cs) c + +-- | 'foldr1'' is like 'foldr1', but strict in the accumulator. +-- +-- @since 0.11.2.0 +foldr1' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldr1' _ Empty = errorEmptyList "foldr1'" +foldr1' f (Chunk c0 cs0) = go c0 cs0 + where go c Empty = S.foldr1' f c + go c (Chunk c' cs) = S.foldr' f (go c' cs) c + +-- --------------------------------------------------------------------- +-- Special folds + +-- | /O(n)/ Concatenate a list of ByteStrings. +concat :: [ByteString] -> ByteString +concat = mconcat + +-- | Map a function over a 'ByteString' and concatenate the results +concatMap :: (Word8 -> ByteString) -> ByteString -> ByteString +concatMap _ Empty = Empty +concatMap f (Chunk c0 cs0) = to c0 cs0 + where + go :: ByteString -> P.ByteString -> ByteString -> ByteString + go Empty c' cs' = to c' cs' + go (Chunk c cs) c' cs' = Chunk c (go cs c' cs') + + to :: P.ByteString -> ByteString -> ByteString + to c cs | S.null c = case cs of + Empty -> Empty + (Chunk c' cs') -> to c' cs' + | otherwise = go (f (S.unsafeHead c)) (S.unsafeTail c) cs + +-- | /O(n)/ Applied to a predicate and a ByteString, 'any' determines if +-- any element of the 'ByteString' satisfies the predicate. +any :: (Word8 -> Bool) -> ByteString -> Bool +any f = foldrChunks (\c rest -> S.any f c || rest) False +{-# INLINE any #-} + +-- | /O(n)/ Applied to a predicate and a 'ByteString', 'all' determines +-- if all elements of the 'ByteString' satisfy the predicate. +all :: (Word8 -> Bool) -> ByteString -> Bool +all f = foldrChunks (\c rest -> S.all f c && rest) True +{-# INLINE all #-} + +-- | /O(n)/ 'maximum' returns the maximum value from a 'ByteString' +maximum :: HasCallStack => ByteString -> Word8 +maximum Empty = errorEmptyList "maximum" +maximum (Chunk c cs) = foldlChunks (\n c' -> n `max` S.maximum c') + (S.maximum c) cs +{-# INLINE maximum #-} + +-- | /O(n)/ 'minimum' returns the minimum value from a 'ByteString' +minimum :: HasCallStack => ByteString -> Word8 +minimum Empty = errorEmptyList "minimum" +minimum (Chunk c cs) = foldlChunks (\n c' -> n `min` S.minimum c') + (S.minimum c) cs +{-# INLINE minimum #-} + +-- | /O(c)/ 'compareLength' compares the length of a 'ByteString' +-- to an 'Int64' +-- +-- @since 0.11.1.0 +compareLength :: ByteString -> Int64 -> Ordering +compareLength _ toCmp | toCmp < 0 = GT +compareLength Empty toCmp = compare 0 toCmp +compareLength (Chunk c cs) toCmp = compareLength cs (toCmp - fromIntegral (S.length c)) +{-# INLINE compareLength #-} + +{-# RULES +"ByteString.Lazy length/compareN -> compareLength" [~1] forall t n. + compare (length t) n = compareLength t n +"ByteString.Lazy compareN/length -> compareLength" [~1] forall t n. + -- compare EQ LT = GT and vice versa + compare n (length t) = compare EQ $ compareLength t n +"ByteString.Lazy length/==N -> compareLength/==EQ" [~1] forall t n. + length t == n = compareLength t n == EQ +"ByteString.Lazy N==/length -> compareLength/==EQ" [~1] forall t n. + n == length t = compareLength t n == EQ +"ByteString.Lazy length//=N -> compareLength//=EQ" [~1] forall t n. + length t /= n = compareLength t n /= EQ +"ByteString.Lazy N/=/length -> compareLength//=EQ" [~1] forall t n. + n /= length t = compareLength t n /= EQ +"ByteString.Lazy length/ compareLength/==LT" [~1] forall t n. + length t < n = compareLength t n == LT +"ByteString.Lazy >N/length -> compareLength/==LT" [~1] forall t n. + n > length t = compareLength t n == LT +"ByteString.Lazy length/<=N -> compareLength//=GT" [~1] forall t n. + length t <= n = compareLength t n /= GT +"ByteString.Lazy <=N/length -> compareLength//=GT" [~1] forall t n. + n >= length t = compareLength t n /= GT +"ByteString.Lazy length/>N -> compareLength/==GT" [~1] forall t n. + length t > n = compareLength t n == GT +"ByteString.Lazy compareLength/==GT" [~1] forall t n. + n < length t = compareLength t n == GT +"ByteString.Lazy length/>=N -> compareLength//=LT" [~1] forall t n. + length t >= n = compareLength t n /= LT +"ByteString.Lazy >=N/length -> compareLength//=LT" [~1] forall t n. + n <= length t = compareLength t n /= LT + #-} + +-- | The 'mapAccumL' function behaves like a combination of 'map' and +-- 'foldl'; it applies a function to each element of a ByteString, +-- passing an accumulating parameter from left to right, and returning a +-- final value of this accumulator together with the new ByteString. +mapAccumL :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) +mapAccumL f = go + where + go s Empty = (s, Empty) + go s (Chunk c cs) = (s'', Chunk c' cs') + where (s', c') = S.mapAccumL f s c + (s'', cs') = go s' cs + +-- | The 'mapAccumR' function behaves like a combination of 'map' and +-- 'foldr'; it applies a function to each element of a ByteString, +-- passing an accumulating parameter from right to left, and returning a +-- final value of this accumulator together with the new ByteString. +mapAccumR :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) +mapAccumR f = go + where + go s Empty = (s, Empty) + go s (Chunk c cs) = (s'', Chunk c' cs') + where (s'', c') = S.mapAccumR f s' c + (s', cs') = go s cs + +-- --------------------------------------------------------------------- +-- Building ByteStrings + +-- | 'scanl' is similar to 'foldl', but returns a list of successive +-- reduced values from the left. +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Note that +-- +-- > head (scanl f z xs) == z +-- > last (scanl f z xs) == foldl f z xs +-- +scanl + :: (Word8 -> Word8 -> Word8) + -- ^ accumulator -> element -> new accumulator + -> Word8 + -- ^ starting value of accumulator + -> ByteString + -- ^ input of length n + -> ByteString + -- ^ output of length n+1 +scanl function = fmap (uncurry (flip snoc)) . mapAccumL (\x y -> (function x y, x)) +{-# INLINE scanl #-} + +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument. +-- +-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] +-- +-- @since 0.11.2.0 +scanl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString +scanl1 function byteStream = case uncons byteStream of + Nothing -> Empty + Just (firstByte, remainingBytes) -> scanl function firstByte remainingBytes + +-- | 'scanr' is similar to 'foldr', but returns a list of successive +-- reduced values from the right. +-- +-- > scanr f z [..., x{n-1}, xn] == [..., x{n-1} `f` (xn `f` z), xn `f` z, z] +-- +-- Note that +-- +-- > head (scanr f z xs) == foldr f z xs +-- > last (scanr f z xs) == z +-- +-- @since 0.11.2.0 +scanr + :: (Word8 -> Word8 -> Word8) + -- ^ element -> accumulator -> new accumulator + -> Word8 + -- ^ starting value of accumulator + -> ByteString + -- ^ input of length n + -> ByteString + -- ^ output of length n+1 +scanr function = fmap (uncurry cons) . mapAccumR (\x y -> (function y x, x)) + +-- | 'scanr1' is a variant of 'scanr' that has no starting value argument. +-- +-- @since 0.11.2.0 +scanr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString +scanr1 function byteStream = case unsnoc byteStream of + Nothing -> Empty + Just (initialBytes, lastByte) -> scanr function lastByte initialBytes + +-- --------------------------------------------------------------------- +-- Unfolds and replicates + +-- | @'iterate' f x@ returns an infinite ByteString of repeated applications +-- of @f@ to @x@: +-- +-- > iterate f x == [x, f x, f (f x), ...] +-- +iterate :: (Word8 -> Word8) -> Word8 -> ByteString +iterate f = unfoldr (\x -> case f x of !x' -> Just (x', x')) + +-- | @'repeat' x@ is an infinite ByteString, with @x@ the value of every +-- element. +-- +repeat :: Word8 -> ByteString +repeat w = cs where cs = Chunk (S.replicate smallChunkSize w) cs + +-- | /O(n)/ @'replicate' n x@ is a ByteString of length @n@ with @x@ +-- the value of every element. +-- +replicate :: Int64 -> Word8 -> ByteString +replicate n w + | n <= 0 = Empty + | n < fromIntegral smallChunkSize = Chunk (S.replicate (fromIntegral n) w) Empty + | r == 0 = cs -- preserve invariant + | otherwise = Chunk (S.unsafeTake (fromIntegral r) c) cs + where + c = S.replicate smallChunkSize w + cs = nChunks q + (q, r) = quotRem n (fromIntegral smallChunkSize) + nChunks 0 = Empty + nChunks m = Chunk c (nChunks (m-1)) + +-- | 'cycle' ties a finite ByteString into a circular one, or equivalently, +-- the infinite repetition of the original ByteString. +-- +cycle :: HasCallStack => ByteString -> ByteString +cycle Empty = errorEmptyList "cycle" +cycle cs = cs' where cs' = foldrChunks Chunk cs' cs + +-- | /O(n)/ The 'unfoldr' function is analogous to the List \'unfoldr\'. +-- 'unfoldr' builds a ByteString from a seed value. The function takes +-- the element and returns 'Nothing' if it is done producing the +-- ByteString or returns 'Just' @(a,b)@, in which case, @a@ is a +-- prepending to the ByteString and @b@ is used as the next element in a +-- recursive call. +unfoldr :: (a -> Maybe (Word8, a)) -> a -> ByteString +unfoldr f = unfoldChunk 32 + where unfoldChunk n x = + case S.unfoldrN n f x of + (c, Nothing) + | S.null c -> Empty + | otherwise -> Chunk c Empty + (c, Just x') -> Chunk c (unfoldChunk (n*2) x') + +-- --------------------------------------------------------------------- +-- Substrings + +-- | /O(n\/c)/ 'take' @n@, applied to a ByteString @xs@, returns the prefix +-- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. +take :: Int64 -> ByteString -> ByteString +take i _ | i <= 0 = Empty +take i cs0 = take' i cs0 + where take' 0 _ = Empty + take' _ Empty = Empty + take' n (Chunk c cs) = + if n < fromIntegral (S.length c) + then Chunk (S.take (fromIntegral n) c) Empty + else Chunk c (take' (n - fromIntegral (S.length c)) cs) + +-- | /O(c)/ @'takeEnd' n xs@ is equivalent to @'drop' ('length' xs - n) xs@. +-- Takes @n@ elements from end of bytestring. +-- +-- >>> takeEnd 3 "abcdefg" +-- "efg" +-- >>> takeEnd 0 "abcdefg" +-- "" +-- >>> takeEnd 4 "abc" +-- "abc" +-- +-- @since 0.11.2.0 +takeEnd :: Int64 -> ByteString -> ByteString +takeEnd i bs + | i <= 0 = Empty + | otherwise = splitAtEndFold (\_ res -> res) id i bs + +-- | Helper function for implementing 'takeEnd' and 'dropEnd' +splitAtEndFold + :: forall result + . (S.StrictByteString -> result -> result) + -- ^ What to do when one chunk of output is ready + -- (The StrictByteString will not be empty.) + -> (ByteString -> result) + -- ^ What to do when the split-point is reached + -> Int64 + -- ^ Number of bytes to leave at the end (must be strictly positive) + -> ByteString -- ^ Input ByteString + -> result +{-# INLINE splitAtEndFold #-} +splitAtEndFold step end len bs0 = assert (len > 0) $ case bs0 of + Empty -> end Empty + Chunk c t -> goR len c t t + where + -- Idea: Keep two references into the input ByteString: + -- "toSplit" tracks the current split point, + -- "toScan" tracks the yet-unprocessed tail. + -- When they are closer than "len" bytes apart, process more input. ("goR") + -- When they are at least "len" bytes apart, produce more output. ("goL") + -- We always have that "toScan" is a suffix of "toSplit", + -- and "toSplit" is a suffix of the original input (bs0). + goR :: Int64 -> S.StrictByteString -> ByteString -> ByteString -> result + goR !undershoot nextOutput@(S.BS noFp noLen) toSplit toScan = + assert (undershoot > 0) $ + -- INVARIANT: length toSplit == length toScan + len - undershoot + -- (not 'assert'ed because that would break our laziness properties) + case toScan of + Empty + | undershoot >= intToInt64 noLen + -> end (Chunk nextOutput toSplit) + | undershootW <- fromIntegral @Int64 @Int undershoot + -- conversion Int64->Int is OK because 0 < undershoot < noLen + , splitIndex <- noLen - undershootW + , beforeSplit <- S.BS noFp splitIndex + , afterSplit <- S.BS (noFp `S.plusForeignPtr` splitIndex) undershootW + -> step beforeSplit $ end (Chunk afterSplit toSplit) + + Chunk (S.BS _ cLen) newBsR + | cLen64 <- intToInt64 cLen + , undershoot > cLen64 + -> goR (undershoot - cLen64) nextOutput toSplit newBsR + | undershootW <- fromIntegral @Int64 @Int undershoot + -> step nextOutput $ goL (cLen - undershootW) toSplit newBsR + + goL :: Int -> ByteString -> ByteString -> result + goL !overshoot toSplit toScan = + assert (overshoot >= 0) $ + -- INVARIANT: length toSplit == length toScan + len + intToInt64 overshoot + -- (not 'assert'ed because that would break our laziness properties) + case toSplit of + Empty -> splitAtEndFoldInvariantFailed + Chunk c@(S.BS _ cLen) newBsL + | overshoot >= cLen + -> step c $ goL (overshoot - cLen) newBsL toScan + | otherwise + -> goR (intToInt64 $ cLen - overshoot) c newBsL toScan + +splitAtEndFoldInvariantFailed :: a +-- See Note [Float error calls out of INLINABLE things] in D.B.Internal.Type +splitAtEndFoldInvariantFailed = + moduleError "splitAtEndFold" + "internal error: toSplit not longer than toScan" + +-- | /O(n\/c)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ +-- elements, or 'empty' if @n > 'length' xs@. +drop :: Int64 -> ByteString -> ByteString +drop i p | i <= 0 = p +drop i cs0 = drop' i cs0 + where drop' 0 cs = cs + drop' _ Empty = Empty + drop' n (Chunk c cs) = + if n < fromIntegral (S.length c) + then Chunk (S.drop (fromIntegral n) c) cs + else drop' (n - fromIntegral (S.length c)) cs + +-- | /O(n)/ @'dropEnd' n xs@ is equivalent to @'take' ('length' xs - n) xs@. +-- Drops @n@ elements from end of bytestring. +-- +-- >>> dropEnd 3 "abcdefg" +-- "abcd" +-- >>> dropEnd 0 "abcdefg" +-- "abcdefg" +-- >>> dropEnd 4 "abc" +-- "" +-- +-- @since 0.11.2.0 +dropEnd :: Int64 -> ByteString -> ByteString +dropEnd i p + | i <= 0 = p + | otherwise = splitAtEndFold Chunk (const Empty) i p + +-- | /O(n\/c)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@. +splitAt :: Int64 -> ByteString -> (ByteString, ByteString) +splitAt i cs0 | i <= 0 = (Empty, cs0) +splitAt i cs0 = splitAt' i cs0 + where splitAt' 0 cs = (Empty, cs) + splitAt' _ Empty = (Empty, Empty) + splitAt' n (Chunk c cs) = + if n < fromIntegral (S.length c) + then (Chunk (S.take (fromIntegral n) c) Empty + ,Chunk (S.drop (fromIntegral n) c) cs) + else let (cs', cs'') = splitAt' (n - fromIntegral (S.length c)) cs + in (Chunk c cs', cs'') + + +-- | Similar to 'Prelude.takeWhile', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate. +takeWhile :: (Word8 -> Bool) -> ByteString -> ByteString +takeWhile f = takeWhile' + where takeWhile' Empty = Empty + takeWhile' (Chunk c cs) = + case S.findIndexOrLength (not . f) c of + 0 -> Empty + n | n < S.length c -> Chunk (S.take n c) Empty + | otherwise -> Chunk c (takeWhile' cs) + +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate. +-- +-- @'takeWhileEnd' p@ is equivalent to @'reverse' . 'takeWhile' p . 'reverse'@. +-- +-- >>> {-# LANGUAGE OverloadedLists #-) +-- >>> takeWhileEnd even [1,2,3,4,6] +-- [4,6] +-- +-- @since 0.11.2.0 +takeWhileEnd :: (Word8 -> Bool) -> ByteString -> ByteString +takeWhileEnd f = takeWhileEnd' + where takeWhileEnd' Empty = Empty + takeWhileEnd' cs = + snd $ foldrChunks takeTuple (True,Empty) cs + takeTuple _ (False, bs) = (False,bs) + takeTuple c (True,bs) = + case S.takeWhileEnd f c of + c' | S.length c' == S.length c -> (True, Chunk c bs) + | otherwise -> (False, fromStrict c' `append` bs) + +-- | Similar to 'Prelude.dropWhile', +-- drops the longest (possibly empty) prefix of elements +-- satisfying the predicate and returns the remainder. +dropWhile :: (Word8 -> Bool) -> ByteString -> ByteString +dropWhile f = dropWhile' + where dropWhile' Empty = Empty + dropWhile' (Chunk c cs) = + case S.findIndexOrLength (not . f) c of + n | n < S.length c -> Chunk (S.drop n c) cs + | otherwise -> dropWhile' cs + +-- | Similar to 'Prelude.dropWhileEnd', +-- drops the longest (possibly empty) suffix of elements +-- satisfying the predicate and returns the remainder. +-- +-- @'dropWhileEnd' p@ is equivalent to @'reverse' . 'dropWhile' p . 'reverse'@. +-- +-- >>> {-# LANGUAGE OverloadedLists #-) +-- >>> dropWhileEnd even [1,2,3,4,6] +-- [1,2,3] +-- +-- @since 0.11.2.0 +dropWhileEnd :: (Word8 -> Bool) -> ByteString -> ByteString +dropWhileEnd f = go [] + where go acc (Chunk c cs) + | f (S.last c) = go (c : acc) cs + | otherwise = List.foldl (flip Chunk) (go [] cs) (c : acc) + go acc Empty = dropEndBytes acc + dropEndBytes [] = Empty + dropEndBytes (x : xs) = + case S.dropWhileEnd f x of + x' | S.null x' -> dropEndBytes xs + | otherwise -> List.foldl' (flip Chunk) Empty (x' : xs) + +-- | Similar to 'Prelude.break', +-- returns the longest (possibly empty) prefix of elements which __do not__ +-- satisfy the predicate and the remainder of the string. +-- +-- 'break' @p@ is equivalent to @'span' (not . p)@ and to @('takeWhile' (not . p) &&& 'dropWhile' (not . p))@. +-- +break :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +break f = break' + where break' Empty = (Empty, Empty) + break' (Chunk c cs) = + case S.findIndexOrLength f c of + 0 -> (Empty, Chunk c cs) + n | n < S.length c -> (Chunk (S.take n c) Empty + ,Chunk (S.drop n c) cs) + | otherwise -> let (cs', cs'') = break' cs + in (Chunk c cs', cs'') + + +-- | Returns the longest (possibly empty) suffix of elements which __do not__ +-- satisfy the predicate and the remainder of the string. +-- +-- 'breakEnd' @p@ is equivalent to @'spanEnd' (not . p)@ and to @('dropWhileEnd' (not . p) &&& 'takeWhileEnd' (not . p))@. +-- +-- @since 0.11.2.0 +breakEnd :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +breakEnd f = go [] + where go acc (Chunk c cs) + | f (S.last c) = List.foldl (flip $ BF.first . Chunk) (go [] cs) (c : acc) + | otherwise = go (c : acc) cs + go acc Empty = dropEndBytes acc + dropEndBytes [] = (Empty, Empty) + dropEndBytes (x : xs) = + case S.breakEnd f x of + (x', x'') | S.null x' -> let (y, y') = dropEndBytes xs + in (y, y' `append` fromStrict x) + | otherwise -> + List.foldl' (flip $ BF.first . Chunk) (fromStrict x', fromStrict x'') xs + + +-- +-- TODO +-- +-- Add rules +-- + +{- +-- | 'breakByte' breaks its ByteString argument at the first occurrence +-- of the specified byte. It is more efficient than 'break' as it is +-- implemented with @memchr(3)@. I.e. +-- +-- > break (==99) "abcd" == breakByte 99 "abcd" -- fromEnum 'c' == 99 +-- +breakByte :: Word8 -> ByteString -> (ByteString, ByteString) +breakByte c (LPS ps) = case (breakByte' ps) of (a,b) -> (LPS a, LPS b) + where breakByte' [] = ([], []) + breakByte' (x:xs) = + case P.elemIndex c x of + Just 0 -> ([], x : xs) + Just n -> (P.take n x : [], P.drop n x : xs) + Nothing -> let (xs', xs'') = breakByte' xs + in (x : xs', xs'') + +-- | 'spanByte' breaks its ByteString argument at the first +-- occurrence of a byte other than its argument. It is more efficient +-- than 'span (==)' +-- +-- > span (==99) "abcd" == spanByte 99 "abcd" -- fromEnum 'c' == 99 +-- +spanByte :: Word8 -> ByteString -> (ByteString, ByteString) +spanByte c (LPS ps) = case (spanByte' ps) of (a,b) -> (LPS a, LPS b) + where spanByte' [] = ([], []) + spanByte' (x:xs) = + case P.spanByte c x of + (x', x'') | P.null x' -> ([], x : xs) + | P.null x'' -> let (xs', xs'') = spanByte' xs + in (x : xs', xs'') + | otherwise -> (x' : [], x'' : xs) +-} + +-- | Similar to 'Prelude.span', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate and the remainder of the string. +-- +-- 'span' @p@ is equivalent to @'break' (not . p)@ and to @('takeWhile' p &&& 'dropWhile' p)@. +-- +span :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +span p = break (not . p) + +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate and the remainder of the string. +-- +-- 'spanEnd' @p@ is equivalent to @'breakEnd' (not . p)@ and to @('dropWhileEnd' p &&& 'takeWhileEnd' p)@. +-- +-- We have +-- +-- > spanEnd (not . isSpace) "x y z" == ("x y ", "z") +-- +-- and +-- +-- > spanEnd (not . isSpace) ps +-- > == +-- > let (x, y) = span (not . isSpace) (reverse ps) in (reverse y, reverse x) +-- +-- @since 0.11.2.0 +spanEnd :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +spanEnd p = breakEnd (not . p) + +-- | /O(n)/ Splits a 'ByteString' into components delimited by +-- separators, where the predicate returns True for a separator element. +-- The resulting components do not contain the separators. Two adjacent +-- separators result in an empty component in the output. eg. +-- +-- > splitWith (==97) "aabbaca" == ["","","bb","c",""] -- fromEnum 'a' == 97 +-- > splitWith undefined "" == [] -- and not [""] +-- +splitWith :: (Word8 -> Bool) -> ByteString -> [ByteString] +splitWith _ Empty = [] +splitWith p (Chunk c0 cs0) = comb [] (S.splitWith p c0) cs0 + + where comb :: [P.ByteString] -> [P.ByteString] -> ByteString -> [ByteString] + comb acc [s] Empty = [revChunks (s:acc)] + comb acc [s] (Chunk c cs) = comb (s:acc) (S.splitWith p c) cs + comb acc (s:ss) cs = revChunks (s:acc) : comb [] ss cs + comb _ [] _ = error "Strict splitWith returned [] for nonempty input" +{-# INLINE splitWith #-} + +-- | /O(n)/ Break a 'ByteString' into pieces separated by the byte +-- argument, consuming the delimiter. I.e. +-- +-- > split 10 "a\nb\nd\ne" == ["a","b","d","e"] -- fromEnum '\n' == 10 +-- > split 97 "aXaXaXa" == ["","X","X","X",""] -- fromEnum 'a' == 97 +-- > split 120 "x" == ["",""] -- fromEnum 'x' == 120 +-- > split undefined "" == [] -- and not [""] +-- +-- and +-- +-- > intercalate [c] . split c == id +-- > split == splitWith . (==) +-- +-- As for all splitting functions in this library, this function does +-- not copy the substrings, it just constructs new 'ByteString's that +-- are slices of the original. +-- +split :: Word8 -> ByteString -> [ByteString] +split _ Empty = [] +split w (Chunk c0 cs0) = comb [] (S.split w c0) cs0 + + where comb :: [P.ByteString] -> [P.ByteString] -> ByteString -> [ByteString] + comb acc [s] Empty = [revChunks (s:acc)] + comb acc [s] (Chunk c cs) = comb (s:acc) (S.split w c) cs + comb acc (s:ss) cs = revChunks (s:acc) : comb [] ss cs + comb _ [] _ = error "Strict split returned [] for nonempty input" +{-# INLINE split #-} + +-- | The 'group' function takes a ByteString and returns a list of +-- ByteStrings such that the concatenation of the result is equal to the +-- argument. Moreover, each string in the result contains only equal +-- elements. For example, +-- +-- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"] +-- +-- It is a special case of 'groupBy', which allows the programmer to +-- supply their own equality test. +group :: ByteString -> [ByteString] +group = go + where + go Empty = [] + go (Chunk c cs) + | S.length c == 1 = to [c] (S.unsafeHead c) cs + | otherwise = to [S.unsafeTake 1 c] (S.unsafeHead c) (Chunk (S.unsafeTail c) cs) + + to acc !_ Empty = [revNonEmptyChunks acc] + to acc !w (Chunk c cs) = + case S.findIndexOrLength (/= w) c of + 0 -> revNonEmptyChunks acc + : go (Chunk c cs) + n | n == S.length c -> to (S.unsafeTake n c : acc) w cs + | otherwise -> revNonEmptyChunks (S.unsafeTake n c : acc) + : go (Chunk (S.unsafeDrop n c) cs) + +-- | The 'groupBy' function is the non-overloaded version of 'group'. +-- +groupBy :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString] +groupBy k = go + where + go Empty = [] + go (Chunk c cs) + | S.length c == 1 = to [c] (S.unsafeHead c) cs + | otherwise = to [S.unsafeTake 1 c] (S.unsafeHead c) (Chunk (S.unsafeTail c) cs) + + to acc !_ Empty = [revNonEmptyChunks acc] + to acc !w (Chunk c cs) = + case S.findIndexOrLength (not . k w) c of + 0 -> revNonEmptyChunks acc + : go (Chunk c cs) + n | n == S.length c -> to (S.unsafeTake n c : acc) w cs + | otherwise -> revNonEmptyChunks (S.unsafeTake n c : acc) + : go (Chunk (S.unsafeDrop n c) cs) + +-- | /O(n)/ The 'intercalate' function takes a 'ByteString' and a list of +-- 'ByteString's and concatenates the list after interspersing the first +-- argument between each element of the list. +intercalate :: ByteString -> [ByteString] -> ByteString +intercalate s = concat . List.intersperse s + +-- --------------------------------------------------------------------- +-- Indexing ByteStrings + +-- | /O(c)/ 'ByteString' index (subscript) operator, starting from 0. +-- +-- This is a partial function, consider using 'indexMaybe' instead. +index :: HasCallStack => ByteString -> Int64 -> Word8 +index _ i | i < 0 = moduleError "index" ("negative index: " ++ show i) +index cs0 i = index' cs0 i + where index' Empty n = moduleError "index" ("index too large: " ++ show n) + index' (Chunk c cs) n + | n >= fromIntegral (S.length c) = + index' cs (n - fromIntegral (S.length c)) + | otherwise = S.unsafeIndex c (fromIntegral n) + +-- | /O(c)/ 'ByteString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 0.11.0.0 +indexMaybe :: ByteString -> Int64 -> Maybe Word8 +indexMaybe _ i | i < 0 = Nothing +indexMaybe cs0 i = index' cs0 i + where index' Empty _ = Nothing + index' (Chunk c cs) n + | n >= fromIntegral (S.length c) = + index' cs (n - fromIntegral (S.length c)) + | otherwise = Just $! S.unsafeIndex c (fromIntegral n) + +-- | /O(1)/ 'ByteString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 0.11.0.0 +(!?) :: ByteString -> Int64 -> Maybe Word8 +(!?) = indexMaybe +{-# INLINE (!?) #-} + +-- | /O(n)/ The 'elemIndex' function returns the index of the first +-- element in the given 'ByteString' which is equal to the query +-- element, or 'Nothing' if there is no such element. +-- This implementation uses memchr(3). +elemIndex :: Word8 -> ByteString -> Maybe Int64 +elemIndex w = elemIndex' 0 + where elemIndex' _ Empty = Nothing + elemIndex' n (Chunk c cs) = + case S.elemIndex w c of + Nothing -> elemIndex' (n + fromIntegral (S.length c)) cs + Just i -> Just (n + fromIntegral i) + +-- | /O(n)/ The 'elemIndexEnd' function returns the last index of the +-- element in the given 'ByteString' which is equal to the query +-- element, or 'Nothing' if there is no such element. The following +-- holds: +-- +-- > elemIndexEnd c xs = case elemIndex c (reverse xs) of +-- > Nothing -> Nothing +-- > Just i -> Just (length xs - 1 - i) +-- +-- @since 0.10.6.0 +elemIndexEnd :: Word8 -> ByteString -> Maybe Int64 +elemIndexEnd = findIndexEnd . (==) +{-# INLINE elemIndexEnd #-} + +-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning +-- the indices of all elements equal to the query element, in ascending order. +-- This implementation uses memchr(3). +elemIndices :: Word8 -> ByteString -> [Int64] +elemIndices w = elemIndices' 0 + where elemIndices' _ Empty = [] + elemIndices' n (Chunk c cs) = List.map ((+n).fromIntegral) (S.elemIndices w c) + ++ elemIndices' (n + fromIntegral (S.length c)) cs + +-- | count returns the number of times its argument appears in the ByteString +-- +-- > count = length . elemIndices +-- +-- But more efficiently than using length on the intermediate list. +count :: Word8 -> ByteString -> Int64 +count w = foldlChunks (\n c -> n + fromIntegral (S.count w c)) 0 + +-- | The 'findIndex' function takes a predicate and a 'ByteString' and +-- returns the index of the first element in the ByteString +-- satisfying the predicate. +findIndex :: (Word8 -> Bool) -> ByteString -> Maybe Int64 +findIndex k = findIndex' 0 + where findIndex' _ Empty = Nothing + findIndex' n (Chunk c cs) = + case S.findIndex k c of + Nothing -> findIndex' (n + fromIntegral (S.length c)) cs + Just i -> Just (n + fromIntegral i) +{-# INLINE findIndex #-} + +-- | The 'findIndexEnd' function takes a predicate and a 'ByteString' and +-- returns the index of the last element in the ByteString +-- satisfying the predicate. +-- +-- @since 0.10.12.0 +findIndexEnd :: (Word8 -> Bool) -> ByteString -> Maybe Int64 +findIndexEnd k = findIndexEnd' 0 + where + findIndexEnd' _ Empty = Nothing + findIndexEnd' n (Chunk c cs) = + let !n' = n + S.length c + !i = fromIntegral . (n +) <$> S.findIndexEnd k c + in findIndexEnd' n' cs `mplus` i +{-# INLINE findIndexEnd #-} + +-- | /O(n)/ The 'find' function takes a predicate and a ByteString, +-- and returns the first element in matching the predicate, or 'Nothing' +-- if there is no such element. +-- +-- > find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing +-- +find :: (Word8 -> Bool) -> ByteString -> Maybe Word8 +find f = find' + where find' Empty = Nothing + find' (Chunk c cs) = case S.find f c of + Nothing -> find' cs + Just w -> Just w +{-# INLINE find #-} + +-- | The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending order. +findIndices :: (Word8 -> Bool) -> ByteString -> [Int64] +findIndices k = findIndices' 0 + where findIndices' _ Empty = [] + findIndices' n (Chunk c cs) = List.map ((+n).fromIntegral) (S.findIndices k c) + ++ findIndices' (n + fromIntegral (S.length c)) cs +{-# INLINE findIndices #-} + +-- --------------------------------------------------------------------- +-- Searching ByteStrings + +-- | /O(n)/ 'elem' is the 'ByteString' membership predicate. +elem :: Word8 -> ByteString -> Bool +elem w cs = case elemIndex w cs of Nothing -> False ; _ -> True + +-- | /O(n)/ 'notElem' is the inverse of 'elem' +notElem :: Word8 -> ByteString -> Bool +notElem w cs = not (w `elem` cs) + +-- | /O(n)/ 'filter', applied to a predicate and a ByteString, +-- returns a ByteString containing those characters that satisfy the +-- predicate. +filter :: (Word8 -> Bool) -> ByteString -> ByteString +filter p = go + where + go Empty = Empty + go (Chunk x xs) = chunk (S.filter p x) (go xs) +{-# INLINE filter #-} + +{- +-- | /O(n)/ and /O(n\/c) space/ A first order equivalent of /filter . +-- (==)/, for the common case of filtering a single byte. It is more +-- efficient to use /filterByte/ in this case. +-- +-- > filterByte == filter . (==) +-- +-- filterByte is around 10x faster, and uses much less space, than its +-- filter equivalent +filterByte :: Word8 -> ByteString -> ByteString +filterByte w ps = replicate (count w ps) w +{-# INLINE filterByte #-} + +{-# RULES +"ByteString specialise filter (== x)" forall x. + filter ((==) x) = filterByte x + +"ByteString specialise filter (== x)" forall x. + filter (== x) = filterByte x + #-} +-} + +{- +-- | /O(n)/ A first order equivalent of /filter . (\/=)/, for the common +-- case of filtering a single byte out of a list. It is more efficient +-- to use /filterNotByte/ in this case. +-- +-- > filterNotByte == filter . (/=) +-- +-- filterNotByte is around 2x faster than its filter equivalent. +filterNotByte :: Word8 -> ByteString -> ByteString +filterNotByte w (LPS xs) = LPS (filterMap (P.filterNotByte w) xs) +-} + +-- | /O(n)/ The 'partition' function takes a predicate a ByteString and returns +-- the pair of ByteStrings with elements which do and do not satisfy the +-- predicate, respectively; i.e., +-- +-- > partition p bs == (filter p xs, filter (not . p) xs) +-- +partition :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +partition _ Empty = (Empty, Empty) +partition p (Chunk x xs) = (chunk t ts, chunk f fs) + where + (t, f) = S.partition p x + (ts, fs) = partition p xs + +-- --------------------------------------------------------------------- +-- Searching for substrings + +-- | /O(n)/ The 'isPrefixOf' function takes two ByteStrings and returns 'True' +-- iff the first is a prefix of the second. +isPrefixOf :: ByteString -> ByteString -> Bool +isPrefixOf Empty _ = True +isPrefixOf _ Empty = False +isPrefixOf (Chunk x xs) (Chunk y ys) + | S.length x == S.length y = x == y && isPrefixOf xs ys + | S.length x < S.length y = x == yh && isPrefixOf xs (Chunk yt ys) + | otherwise = xh == y && isPrefixOf (Chunk xt xs) ys + where (xh,xt) = S.splitAt (S.length y) x + (yh,yt) = S.splitAt (S.length x) y + +-- | /O(n)/ The 'stripPrefix' function takes two ByteStrings and returns 'Just' +-- the remainder of the second iff the first is its prefix, and otherwise +-- 'Nothing'. +-- +-- @since 0.10.8.0 +stripPrefix :: ByteString -> ByteString -> Maybe ByteString +stripPrefix Empty bs = Just bs +stripPrefix _ Empty = Nothing +stripPrefix (Chunk x xs) (Chunk y ys) + | S.length x == S.length y = if x == y then stripPrefix xs ys else Nothing + | S.length x < S.length y = do yt <- S.stripPrefix x y + stripPrefix xs (Chunk yt ys) + | otherwise = do xt <- S.stripPrefix y x + stripPrefix (Chunk xt xs) ys + +-- | /O(n)/ The 'isSuffixOf' function takes two ByteStrings and returns 'True' +-- iff the first is a suffix of the second. +-- +-- The following holds: +-- +-- > isSuffixOf x y == reverse x `isPrefixOf` reverse y +-- +isSuffixOf :: ByteString -> ByteString -> Bool +isSuffixOf x y = reverse x `isPrefixOf` reverse y +--TODO: a better implementation + +-- | /O(n)/ The 'stripSuffix' function takes two ByteStrings and returns 'Just' +-- the remainder of the second iff the first is its suffix, and otherwise +-- 'Nothing'. +stripSuffix :: ByteString -> ByteString -> Maybe ByteString +stripSuffix x y = reverse <$> stripPrefix (reverse x) (reverse y) +--TODO: a better implementation + +-- --------------------------------------------------------------------- +-- Zipping + +-- | /O(n)/ 'zip' takes two ByteStrings and returns a list of +-- corresponding pairs of bytes. If one input ByteString is short, +-- excess elements of the longer ByteString are discarded. This is +-- equivalent to a pair of 'unpack' operations. +zip :: ByteString -> ByteString -> [(Word8,Word8)] +zip = zipWith (,) + +-- | 'zipWith' generalises 'zip' by zipping with the function given as +-- the first argument, instead of a tupling function. For example, +-- @'zipWith' (+)@ is applied to two ByteStrings to produce the list of +-- corresponding sums. +zipWith :: (Word8 -> Word8 -> a) -> ByteString -> ByteString -> [a] +zipWith _ Empty _ = [] +zipWith _ _ Empty = [] +zipWith f (Chunk a as) (Chunk b bs) = go a as b bs + where + -- This loop is written in a slightly awkward way but ensures we + -- don't have to allocate any 'Chunk' objects to pass to a recursive + -- call. We have in some sense performed SpecConstr manually. + go !x xs !y ys = let + -- Creating a thunk for reading one byte would + -- be wasteful, so we evaluate these eagerly. + -- See also #558 for a similar issue with uncons. + !xHead = S.unsafeHead x + !yHead = S.unsafeHead y + in f xHead yHead : to (S.unsafeTail x) xs (S.unsafeTail y) ys + + to !x xs !y ys + | Chunk x' xs' <- chunk x xs + , Chunk y' ys' <- chunk y ys + = go x' xs' y' ys' + | otherwise = [] + +-- | A specialised version of `zipWith` for the common case of a +-- simultaneous map over two ByteStrings, to build a 3rd. +-- +-- @since 0.11.1.0 +packZipWith :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> ByteString +packZipWith _ Empty _ = Empty +packZipWith _ _ Empty = Empty +packZipWith f (Chunk a@(S.BS _ al) as) (Chunk b@(S.BS _ bl) bs) = Chunk (S.packZipWith f a b) $ + case compare al bl of + LT -> packZipWith f as $ Chunk (S.drop al b) bs + EQ -> packZipWith f as bs + GT -> packZipWith f (Chunk (S.drop bl a) as) bs +{-# INLINE packZipWith #-} + +-- | /O(n)/ 'unzip' transforms a list of pairs of bytes into a pair of +-- ByteStrings. Note that this performs two 'pack' operations. +unzip :: [(Word8,Word8)] -> (ByteString,ByteString) +unzip ls = (pack (List.map fst ls), pack (List.map snd ls)) +{-# INLINE unzip #-} + +-- --------------------------------------------------------------------- +-- Special lists + +-- | Returns all initial segments of the given 'ByteString', shortest first. +inits :: ByteString -> [ByteString] +-- see Note [Avoid NonEmpty combinators] in Data.ByteString +inits bs = NE.toList $! initsNE bs + +-- | Returns all initial segments of the given 'ByteString', shortest first. +-- +-- @since 0.11.4.0 +initsNE :: ByteString -> NonEmpty ByteString +-- see Note [Avoid NonEmpty combinators] in Data.ByteString +initsNE = (Empty :|) . inits' id + where + inits' :: (ByteString -> ByteString) -> ByteString -> [ByteString] + -- inits' f bs === map f (tail (inits bs)) + inits' _ Empty = [] + inits' f (Chunk c@(S.BS x len) cs) + = [f (S.BS x n `Chunk` Empty) | n <- [1..len]] + ++ inits' (f . Chunk c) cs + +-- | /O(n)/ Returns all final segments of the given 'ByteString', longest first. +tails :: ByteString -> [ByteString] +-- see Note [Avoid NonEmpty combinators] in Data.ByteString +tails bs = NE.toList $! tailsNE bs + +-- | /O(n)/ Returns all final segments of the given 'ByteString', longest first. +-- +-- @since 0.11.4.0 +tailsNE :: ByteString -> NonEmpty ByteString +-- see Note [Avoid NonEmpty combinators] in Data.ByteString +tailsNE bs = case uncons bs of + Nothing -> Empty :| [] + Just (_, tl) -> bs :| tails tl + + +-- --------------------------------------------------------------------- +-- Low level constructors + +-- | /O(n)/ Make a copy of the 'ByteString' with its own storage. +-- This is mainly useful to allow the rest of the data pointed +-- to by the 'ByteString' to be garbage collected, for example +-- if a large string has been read in, and only a small part of it +-- is needed in the rest of the program. +copy :: ByteString -> ByteString +copy = foldrChunks (Chunk . S.copy) Empty +--TODO, we could coalese small blocks here +--FIXME: probably not strict enough, if we're doing this to avoid retaining +-- the parent blocks then we'd better copy strictly. + +-- --------------------------------------------------------------------- + +-- TODO defrag func that concatenates block together that are below a threshold +-- defrag :: ByteString -> ByteString + +-- --------------------------------------------------------------------- +-- Lazy ByteString IO +-- +-- Rule for when to close: is it expected to read the whole file? +-- If so, close when done. +-- + +-- | Read entire handle contents /lazily/ into a 'ByteString'. Chunks +-- are read on demand, in at most @k@-sized chunks. It does not block +-- waiting for a whole @k@-sized chunk, so if less than @k@ bytes are +-- available then they will be returned immediately as a smaller chunk. +-- +-- The handle is closed on EOF. +-- +hGetContentsN :: Int -> Handle -> IO ByteString +hGetContentsN k h = lazyRead -- TODO close on exceptions + where + lazyRead = unsafeInterleaveIO loop + + loop = do + c <- S.hGetSome h k -- only blocks if there is no data available + if S.null c + then hClose h >> return Empty + else Chunk c <$> lazyRead + +-- | Read @n@ bytes into a 'ByteString', directly from the +-- specified 'Handle', in chunks of size @k@. +-- +hGetN :: Int -> Handle -> Int -> IO ByteString +hGetN k h n | n > 0 = readChunks n + where + readChunks !i = do + c <- S.hGet h (min k i) + case S.length c of + 0 -> return Empty + m -> do cs <- readChunks (i - m) + return (Chunk c cs) + +hGetN _ _ 0 = return Empty +hGetN _ h n = illegalBufferSize h "hGet" n + +-- | hGetNonBlockingN is similar to 'hGetContentsN', except that it will never block +-- waiting for data to become available, instead it returns only whatever data +-- is available. Chunks are read on demand, in @k@-sized chunks. +-- +hGetNonBlockingN :: Int -> Handle -> Int -> IO ByteString +hGetNonBlockingN k h n | n > 0= readChunks n + where + readChunks !i = do + c <- S.hGetNonBlocking h (min k i) + case S.length c of + 0 -> return Empty + m -> do cs <- readChunks (i - m) + return (Chunk c cs) + +hGetNonBlockingN _ _ 0 = return Empty +hGetNonBlockingN _ h n = illegalBufferSize h "hGetNonBlocking" n + +illegalBufferSize :: Handle -> String -> Int -> IO a +illegalBufferSize handle fn sz = + ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing) + --TODO: System.IO uses InvalidArgument here, but it's not exported :-( + where + msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz [] + +-- | Read entire handle contents /lazily/ into a 'ByteString'. Chunks +-- are read on demand, using the default chunk size. +-- +-- File handles are closed on EOF if all the file is read, or through +-- garbage collection otherwise. +-- +hGetContents :: Handle -> IO ByteString +hGetContents = hGetContentsN defaultChunkSize + +-- | Read @n@ bytes into a 'ByteString', directly from the specified 'Handle'. +-- +hGet :: Handle -> Int -> IO ByteString +hGet = hGetN defaultChunkSize + +-- | hGetNonBlocking is similar to 'hGet', except that it will never block +-- waiting for data to become available, instead it returns only whatever data +-- is available. If there is no data available to be read, 'hGetNonBlocking' +-- returns 'empty'. +-- +-- Note: on Windows and with Haskell implementation other than GHC, this +-- function does not work correctly; it behaves identically to 'hGet'. +-- +hGetNonBlocking :: Handle -> Int -> IO ByteString +hGetNonBlocking = hGetNonBlockingN defaultChunkSize + +-- | Read an entire file /lazily/ into a 'ByteString'. +-- +-- The 'Handle' will be held open until EOF is encountered. +-- +-- Note that this function's implementation relies on 'hGetContents'. +-- The reader is advised to read its documentation. +-- +readFile :: FilePath -> IO ByteString +readFile f = openBinaryFile f ReadMode >>= hGetContents + +modifyFile :: IOMode -> FilePath -> ByteString -> IO () +modifyFile mode f txt = withBinaryFile f mode (`hPut` txt) + +-- | Write a 'ByteString' to a file. +-- +writeFile :: FilePath -> ByteString -> IO () +writeFile = modifyFile WriteMode + +-- | Append a 'ByteString' to a file. +-- +appendFile :: FilePath -> ByteString -> IO () +appendFile = modifyFile AppendMode + +-- | getContents. Equivalent to hGetContents stdin. Will read /lazily/ +-- +getContents :: IO ByteString +getContents = hGetContents stdin + +-- | Outputs a 'ByteString' to the specified 'Handle'. +-- +-- The chunks will be +-- written one at a time. Other threads might write to the 'Handle' in between, +-- and hence 'hPut' alone is not suitable for concurrent writes. +-- +hPut :: Handle -> ByteString -> IO () +hPut h = foldrChunks (\c rest -> S.hPut h c >> rest) (return ()) + +-- | Similar to 'hPut' except that it will never block. Instead it returns +-- any tail that did not get written. This tail may be 'empty' in the case that +-- the whole string was written, or the whole original string if nothing was +-- written. Partial writes are also possible. +-- +-- Note: on Windows and with Haskell implementation other than GHC, this +-- function does not work correctly; it behaves identically to 'hPut'. +-- +hPutNonBlocking :: Handle -> ByteString -> IO ByteString +hPutNonBlocking _ Empty = return Empty +hPutNonBlocking h bs@(Chunk c cs) = do + c' <- S.hPutNonBlocking h c + case S.length c' of + l' | l' == S.length c -> hPutNonBlocking h cs + 0 -> return bs + _ -> return (Chunk c' cs) + +-- | A synonym for 'hPut', for compatibility +-- +hPutStr :: Handle -> ByteString -> IO () +hPutStr = hPut + +-- | Write a ByteString to 'stdout'. +-- +-- The chunks will be +-- written one at a time. Other threads might write to the 'stdout' in between, +-- and hence 'putStr' alone is not suitable for concurrent writes. +-- +putStr :: ByteString -> IO () +putStr = hPut stdout + +-- | The interact function takes a function of type @ByteString -> ByteString@ +-- as its argument. The entire input from the standard input device is passed +-- to this function as its argument, and the resulting string is output on the +-- standard output device. +-- +interact :: (ByteString -> ByteString) -> IO () +interact transformer = putStr . transformer =<< getContents + +-- --------------------------------------------------------------------- +-- Internal utilities + +-- Common up near identical calls to `error' to reduce the number +-- constant strings created when compiled: +errorEmptyList :: HasCallStack => String -> a +errorEmptyList fun = moduleError fun "empty ByteString" +{-# NOINLINE errorEmptyList #-} + +moduleError :: HasCallStack => String -> String -> a +moduleError fun msg = error ("Data.ByteString.Lazy." ++ fun ++ ':':' ':msg) +{-# NOINLINE moduleError #-} + + +-- reverse a list of non-empty chunks into a lazy ByteString +revNonEmptyChunks :: [P.ByteString] -> ByteString +revNonEmptyChunks = List.foldl' (flip Chunk) Empty + +-- reverse a list of possibly-empty chunks into a lazy ByteString +revChunks :: [P.ByteString] -> ByteString +revChunks = List.foldl' (flip chunk) Empty + +intToInt64 :: Int -> Int64 +intToInt64 = fromIntegral @Int @Int64 + +-- $IOChunk +-- +-- ⚠ Using lazy I\/O functions like 'readFile' or 'hGetContents' +-- means that the order of operations such as closing the file handle +-- is left at the discretion of the RTS. +-- Hence, the developer can face some issues when: +-- +-- * The program reads a file and writes the same file. This means that the file +-- may be locked because the handler has not been released when 'writeFile' is executed. +-- * The program reads thousands of files, but due to lazy evaluation, the OS's file descriptor +-- limit is reached before the handlers can be released. +-- +-- === Why? +-- +-- Consider the following program: +-- +-- > import qualified Data.ByteString.Lazy as BL +-- > main = do +-- > _ <- BL.readFile "foo.txt" +-- > BL.writeFile "foo.txt" mempty +-- +-- Generally, in the 'IO' monad side effects happen +-- sequentially and in full. Therefore, one might reasonably expect that +-- reading the whole file via 'readFile' executes all three actions +-- (open the file handle, read its content, close the file handle) before +-- control moves to the following 'writeFile' action. This expectation holds +-- for the strict "Data.ByteString" API. However, the above 'LazyByteString' variant +-- of the program fails with @openBinaryFile: resource busy (file is locked)@. +-- +-- The reason for this is that "Data.ByteString.Lazy" is specifically designed +-- to handle large or unbounded streams of data incrementally, without requiring all the data +-- to be resident in memory at the same time. Incremental processing would not be possible +-- if 'readFile' were to follow the usual rules of 'IO': evaluating all side effects +-- would require reading the file in full and closing its handle before returning from 'readFile'. This is why +-- 'readFile' (and 'hGetContents' in general) is implemented +-- via 'unsafeInterleaveIO', which allows 'IO' side effects to be delayed and +-- interleaved with subsequent processing of the return value. +-- That's exactly what happens +-- in the example above: 'readFile' opens a file handle, but since the content +-- is not fully consumed, the file handle remains open, allowing the content to +-- read __on demand__ (never in this case, since the return value is ignored). +-- So when 'writeFile' is executed next, @foo.txt@ is still open for reading and +-- the RTS takes care to avoid simultaneously opening it for writing, instead +-- returning the error shown above. +-- +-- === How to enforce the order of effects? +-- +-- If the content is small enough to fit in memory, +-- consider using strict 'Data.ByteString.readFile', +-- potentially applying 'fromStrict' afterwards. E. g., +-- +-- > import qualified Data.ByteString as BS +-- > import qualified Data.ByteString.Lazy as BL +-- > main = do +-- > _ <- BS.readFile "foo.txt" +-- > BL.writeFile "foo.txt" mempty +-- +-- If you are dealing with large or unbounded data streams, +-- consider reaching out for a specialised package, such as +-- , +-- , +-- , +-- , +-- , +-- etc. diff --git a/Data/ByteString/Lazy/Builder.hs b/Data/ByteString/Lazy/Builder.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder.hs +++ /dev/null @@ -1,451 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{- | Copyright : (c) 2010 Jasper Van der Jeugt - (c) 2010 - 2011 Simon Meier -License : BSD3-style (see LICENSE) -Maintainer : Simon Meier -Portability : GHC - -'Builder's are used to efficiently construct sequences of bytes from - smaller parts. -Typically, - such a construction is part of the implementation of an /encoding/, i.e., - a function for converting Haskell values to sequences of bytes. -Examples of encodings are the generation of the sequence of bytes - representing a HTML document to be sent in a HTTP response by a - web application or the serialization of a Haskell value using - a fixed binary format. - -For an /efficient implementation of an encoding/, - it is important that (a) little time is spent on converting - the Haskell values to the resulting sequence of bytes /and/ - (b) that the representation of the resulting sequence - is such that it can be consumed efficiently. -'Builder's support (a) by providing an /O(1)/ concatentation operation - and efficient implementations of basic encodings for 'Char's, 'Int's, - and other standard Haskell values. -They support (b) by providing their result as a lazy 'L.ByteString', - which is internally just a linked list of pointers to /chunks/ - of consecutive raw memory. -Lazy 'L.ByteString's can be efficiently consumed by functions that - write them to a file or send them over a network socket. -Note that each chunk boundary incurs expensive extra work (e.g., a system call) - that must be amortized over the work spent on consuming the chunk body. -'Builder's therefore take special care to ensure that the - average chunk size is large enough. -The precise meaning of large enough is application dependent. -The current implementation is tuned - for an average chunk size between 4kb and 32kb, - which should suit most applications. - -As a simple example of an encoding implementation, - we show how to efficiently convert the following representation of mixed-data - tables to an UTF-8 encoded Comma-Separated-Values (CSV) table. - ->data Cell = StringC String -> | IntC Int -> deriving( Eq, Ord, Show ) -> ->type Row = [Cell] ->type Table = [Row] - -We use the following imports and abbreviate 'mappend' to simplify reading. - -@ -import qualified "Data.ByteString.Lazy" as L -import "Data.ByteString.Lazy.Builder" -import "Data.ByteString.Lazy.Builder.ASCII" ('intDec') -import Data.Monoid -import Data.Foldable ('foldMap') -import Data.List ('intersperse') - -infixr 4 \<\> -(\<\>) :: 'Monoid' m => m -> m -> m -(\<\>) = 'mappend' -@ - -CSV is a character-based representation of tables. For maximal modularity, -we could first render 'Table's as 'String's and then encode this 'String' -using some Unicode character encoding. However, this sacrifices performance -due to the intermediate 'String' representation being built and thrown away -right afterwards. We get rid of this intermediate 'String' representation by -fixing the character encoding to UTF-8 and using 'Builder's to convert -'Table's directly to UTF-8 encoded CSV tables represented as lazy -'L.ByteString's. - -@ -encodeUtf8CSV :: Table -> L.ByteString -encodeUtf8CSV = 'toLazyByteString' . renderTable - -renderTable :: Table -> Builder -renderTable rs = 'mconcat' [renderRow r \<\> 'charUtf8' \'\\n\' | r <- rs] - -renderRow :: Row -> Builder -renderRow [] = 'mempty' -renderRow (c:cs) = - renderCell c \<\> mconcat [ charUtf8 \',\' \<\> renderCell c\' | c\' <- cs ] - -renderCell :: Cell -> Builder -renderCell (StringC cs) = renderString cs -renderCell (IntC i) = 'intDec' i - -renderString :: String -> Builder -renderString cs = charUtf8 \'\"\' \<\> foldMap escape cs \<\> charUtf8 \'\"\' - where - escape \'\\\\\' = charUtf8 \'\\\\\' \<\> charUtf8 \'\\\\\' - escape \'\\\"\' = charUtf8 \'\\\\\' \<\> charUtf8 \'\\\"\' - escape c = charUtf8 c -@ - -Note that the ASCII encoding is a subset of the UTF-8 encoding, - which is why we can use the optimized function 'intDec' to - encode an 'Int' as a decimal number with UTF-8 encoded digits. -Using 'intDec' is more efficient than @'stringUtf8' . 'show'@, - as it avoids constructing an intermediate 'String'. -Avoiding this intermediate data structure significantly improves - performance because encoding 'Cell's is the core operation - for rendering CSV-tables. -See "Data.ByteString.Lazy.Builder.BasicEncoding" for further - information on how to improve the performance of 'renderString'. - -We demonstrate our UTF-8 CSV encoding function on the following table. - -@ -strings :: [String] -strings = [\"hello\", \"\\\"1\\\"\", \"λ-wörld\"] - -table :: Table -table = [map StringC strings, map IntC [-3..3]] -@ - -The expression @encodeUtf8CSV table@ results in the following lazy -'L.ByteString'. - ->Chunk "\"hello\",\"\\\"1\\\"\",\"\206\187-w\195\182rld\"\n-3,-2,-1,0,1,2,3\n" Empty - -We can clearly see that we are converting to a /binary/ format. The \'λ\' -and \'ö\' characters, which have a Unicode codepoint above 127, are -expanded to their corresponding UTF-8 multi-byte representation. - -We use the @criterion@ library () - to benchmark the efficiency of our encoding function on the following table. - ->import Criterion.Main -- add this import to the ones above -> ->maxiTable :: Table ->maxiTable = take 1000 $ cycle table -> ->main :: IO () ->main = defaultMain -> [ bench "encodeUtf8CSV maxiTable (original)" $ -> whnf (L.length . encodeUtf8CSV) maxiTable -> ] - -On a Core2 Duo 2.20GHz on a 32-bit Linux, - the above code takes 1ms to generate the 22'500 bytes long lazy 'L.ByteString'. -Looking again at the definitions above, - we see that we took care to avoid intermediate data structures, - as otherwise we would sacrifice performance. -For example, - the following (arguably simpler) definition of 'renderRow' is about 20% slower. - ->renderRow :: Row -> Builder ->renderRow = mconcat . intersperse (charUtf8 ',') . map renderCell - -Similarly, using /O(n)/ concatentations like '++' or the equivalent 'S.concat' - operations on strict and lazy 'L.ByteString's should be avoided. -The following definition of 'renderString' is also about 20% slower. - ->renderString :: String -> Builder ->renderString cs = charUtf8 $ "\"" ++ concatMap escape cs ++ "\"" -> where -> escape '\\' = "\\" -> escape '\"' = "\\\"" -> escape c = return c - -Apart from removing intermediate data-structures, - encodings can be optimized further by fine-tuning their execution - parameters using the functions in "Data.ByteString.Lazy.Builder.Extras" and - their \"inner loops\" using the functions in - "Data.ByteString.Lazy.Builder.BasicEncoding". --} - - -module Data.ByteString.Lazy.Builder - ( - -- * The Builder type - Builder - - -- * Executing Builders - -- | Internally, 'Builder's are buffer-filling functions. They are - -- executed by a /driver/ that provides them with an actual buffer to - -- fill. Once called with a buffer, a 'Builder' fills it and returns a - -- signal to the driver telling it that it is either done, has filled the - -- current buffer, or wants to directly insert a reference to a chunk of - -- memory. In the last two cases, the 'Builder' also returns a - -- continutation 'Builder' that the driver can call to fill the next - -- buffer. Here, we provide the two drivers that satisfy almost all use - -- cases. See "Data.ByteString.Lazy.Builder.Extras", for information - -- about fine-tuning them. - , toLazyByteString - , hPutBuilder - - -- * Creating Builders - - -- ** Binary encodings - , byteString - , lazyByteString - , int8 - , word8 - - -- *** Big-endian - , int16BE - , int32BE - , int64BE - - , word16BE - , word32BE - , word64BE - - , floatBE - , doubleBE - - -- *** Little-endian - , int16LE - , int32LE - , int64LE - - , word16LE - , word32LE - , word64LE - - , floatLE - , doubleLE - - -- ** Character encodings - - -- *** ASCII (Char7) - -- | The ASCII encoding is a 7-bit encoding. The /Char7/ encoding implemented here - -- works by truncating the Unicode codepoint to 7-bits, prefixing it - -- with a leading 0, and encoding the resulting 8-bits as a single byte. - -- For the codepoints 0-127 this corresponds the ASCII encoding. In - -- "Data.ByteString.Lazy.Builder.ASCII", we also provide efficient - -- implementations of ASCII-based encodings of numbers (e.g., decimal and - -- hexadecimal encodings). - , char7 - , string7 - - -- *** ISO/IEC 8859-1 (Char8) - -- | The ISO/IEC 8859-1 encoding is an 8-bit encoding often known as Latin-1. - -- The /Char8/ encoding implemented here works by truncating the Unicode codepoint - -- to 8-bits and encoding them as a single byte. For the codepoints 0-255 this corresponds - -- to the ISO/IEC 8859-1 encoding. Note that you can also use - -- the functions from "Data.ByteString.Lazy.Builder.ASCII", as the ASCII encoding - -- and ISO/IEC 8859-1 are equivalent on the codepoints 0-127. - , char8 - , string8 - - -- *** UTF-8 - -- | The UTF-8 encoding can encode /all/ Unicode codepoints. We recommend - -- using it always for encoding 'Char's and 'String's unless an application - -- really requires another encoding. Note that you can also use the - -- functions from "Data.ByteString.Lazy.Builder.ASCII" for UTF-8 encoding, - -- as the ASCII encoding is equivalent to the UTF-8 encoding on the Unicode - -- codepoints 0-127. - , charUtf8 - , stringUtf8 - - - ) where - -import Data.ByteString.Lazy.Builder.Internal -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E -import qualified Data.ByteString.Lazy.Internal as L - -import System.IO (Handle) -import Foreign - --- HADDOCK only imports -import Data.ByteString.Lazy.Builder.ASCII (intDec) -import qualified Data.ByteString as S (concat) -import Data.Monoid -import Data.Foldable (foldMap) -import Data.List (intersperse) - - --- | Execute a 'Builder' and return the generated chunks as a lazy 'L.ByteString'. --- The work is performed lazy, i.e., only when a chunk of the lazy 'L.ByteString' --- is forced. -{-# NOINLINE toLazyByteString #-} -- ensure code is shared -toLazyByteString :: Builder -> L.ByteString -toLazyByteString = toLazyByteStringWith - (safeStrategy L.smallChunkSize L.defaultChunkSize) L.Empty - -{- Not yet stable enough. - See note on 'hPut' in Data.ByteString.Lazy.Builder.Internal --} - --- | Output a 'Builder' to a 'Handle'. --- The 'Builder' is executed directly on the buffer of the 'Handle'. If the --- buffer is too small (or not present), then it is replaced with a large --- enough buffer. --- --- It is recommended that the 'Handle' is set to binary and --- 'BlockBuffering' mode. See 'hSetBinaryMode' and 'hSetBuffering'. --- --- This function is more efficient than @hPut . 'toLazyByteString'@ because in --- many cases no buffer allocation has to be done. Moreover, the results of --- several executions of short 'Builder's are concatenated in the 'Handle's --- buffer, therefore avoiding unnecessary buffer flushes. -hPutBuilder :: Handle -> Builder -> IO () -hPutBuilder h = hPut h . putBuilder - - ------------------------------------------------------------------------------- --- Binary encodings ------------------------------------------------------------------------------- - --- | Encode a single signed byte as-is. --- -{-# INLINE int8 #-} -int8 :: Int8 -> Builder -int8 = E.encodeWithF E.int8 - --- | Encode a single unsigned byte as-is. --- -{-# INLINE word8 #-} -word8 :: Word8 -> Builder -word8 = E.encodeWithF E.word8 - - ------------------------------------------------------------------------------- --- Binary little-endian encodings ------------------------------------------------------------------------------- - --- | Encode an 'Int16' in little endian format. -{-# INLINE int16LE #-} -int16LE :: Int16 -> Builder -int16LE = E.encodeWithF E.int16LE - --- | Encode an 'Int32' in little endian format. -{-# INLINE int32LE #-} -int32LE :: Int32 -> Builder -int32LE = E.encodeWithF E.int32LE - --- | Encode an 'Int64' in little endian format. -{-# INLINE int64LE #-} -int64LE :: Int64 -> Builder -int64LE = E.encodeWithF E.int64LE - --- | Encode a 'Word16' in little endian format. -{-# INLINE word16LE #-} -word16LE :: Word16 -> Builder -word16LE = E.encodeWithF E.word16LE - --- | Encode a 'Word32' in little endian format. -{-# INLINE word32LE #-} -word32LE :: Word32 -> Builder -word32LE = E.encodeWithF E.word32LE - --- | Encode a 'Word64' in little endian format. -{-# INLINE word64LE #-} -word64LE :: Word64 -> Builder -word64LE = E.encodeWithF E.word64LE - --- | Encode a 'Float' in little endian format. -{-# INLINE floatLE #-} -floatLE :: Float -> Builder -floatLE = E.encodeWithF E.floatLE - --- | Encode a 'Double' in little endian format. -{-# INLINE doubleLE #-} -doubleLE :: Double -> Builder -doubleLE = E.encodeWithF E.doubleLE - - ------------------------------------------------------------------------------- --- Binary big-endian encodings ------------------------------------------------------------------------------- - --- | Encode an 'Int16' in big endian format. -{-# INLINE int16BE #-} -int16BE :: Int16 -> Builder -int16BE = E.encodeWithF E.int16BE - --- | Encode an 'Int32' in big endian format. -{-# INLINE int32BE #-} -int32BE :: Int32 -> Builder -int32BE = E.encodeWithF E.int32BE - --- | Encode an 'Int64' in big endian format. -{-# INLINE int64BE #-} -int64BE :: Int64 -> Builder -int64BE = E.encodeWithF E.int64BE - --- | Encode a 'Word16' in big endian format. -{-# INLINE word16BE #-} -word16BE :: Word16 -> Builder -word16BE = E.encodeWithF E.word16BE - --- | Encode a 'Word32' in big endian format. -{-# INLINE word32BE #-} -word32BE :: Word32 -> Builder -word32BE = E.encodeWithF E.word32BE - --- | Encode a 'Word64' in big endian format. -{-# INLINE word64BE #-} -word64BE :: Word64 -> Builder -word64BE = E.encodeWithF E.word64BE - --- | Encode a 'Float' in big endian format. -{-# INLINE floatBE #-} -floatBE :: Float -> Builder -floatBE = E.encodeWithF E.floatBE - --- | Encode a 'Double' in big endian format. -{-# INLINE doubleBE #-} -doubleBE :: Double -> Builder -doubleBE = E.encodeWithF E.doubleBE - ------------------------------------------------------------------------------- --- ASCII encoding ------------------------------------------------------------------------------- - --- | Char7 encode a 'Char'. -{-# INLINE char7 #-} -char7 :: Char -> Builder -char7 = E.encodeWithF E.char7 - --- | Char7 encode a 'String'. -{-# INLINE string7 #-} -string7 :: String -> Builder -string7 = E.encodeListWithF E.char7 - ------------------------------------------------------------------------------- --- ISO/IEC 8859-1 encoding ------------------------------------------------------------------------------- - --- | Char8 encode a 'Char'. -{-# INLINE char8 #-} -char8 :: Char -> Builder -char8 = E.encodeWithF E.char8 - --- | Char8 encode a 'String'. -{-# INLINE string8 #-} -string8 :: String -> Builder -string8 = E.encodeListWithF E.char8 - ------------------------------------------------------------------------------- --- UTF-8 encoding ------------------------------------------------------------------------------- - --- | UTF-8 encode a 'Char'. -{-# INLINE charUtf8 #-} -charUtf8 :: Char -> Builder -charUtf8 = E.encodeWithB E.charUtf8 - --- | UTF-8 encode a 'String'. -{-# INLINE stringUtf8 #-} -stringUtf8 :: String -> Builder -stringUtf8 = E.encodeListWithB E.charUtf8 - diff --git a/Data/ByteString/Lazy/Builder/ASCII.hs b/Data/ByteString/Lazy/Builder/ASCII.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/ASCII.hs +++ /dev/null @@ -1,268 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface #-} --- | Copyright : (c) 2010 - 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC --- --- Constructing 'Builder's using ASCII-based encodings. --- -module Data.ByteString.Lazy.Builder.ASCII - ( - -- * Decimal numbers - -- | Decimal encoding of numbers using ASCII encoded characters. - int8Dec - , int16Dec - , int32Dec - , int64Dec - , intDec - , integerDec - - , word8Dec - , word16Dec - , word32Dec - , word64Dec - , wordDec - - , floatDec - , doubleDec - - -- * Hexadecimal numbers - - -- | Encoding positive integers as hexadecimal numbers using lower-case - -- ASCII characters. The shortest - -- possible representation is used. For example, - -- - -- >>> toLazyByteString (word16Hex 0x0a10) - -- Chunk "a10" Empty - -- - -- Note that there is no support for using upper-case characters. Please - -- contact the maintainer, if your application cannot work without - -- hexadecimal encodings that use upper-case characters. - -- - , word8Hex - , word16Hex - , word32Hex - , word64Hex - , wordHex - - -- * Fixed-width hexadecimal numbers - -- - , int8HexFixed - , int16HexFixed - , int32HexFixed - , int64HexFixed - , word8HexFixed - , word16HexFixed - , word32HexFixed - , word64HexFixed - - , floatHexFixed - , doubleHexFixed - - , byteStringHexFixed - , lazyByteStringHexFixed - - ) where - -import Data.ByteString as S -import Data.ByteString.Lazy.Internal as L -import Data.ByteString.Lazy.Builder.Internal (Builder) -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E - -import Foreign - ------------------------------------------------------------------------------- --- Decimal Encoding ------------------------------------------------------------------------------- - - --- | Encode a 'String' using 'E.char7'. -{-# INLINE string7 #-} -string7 :: String -> Builder -string7 = E.encodeListWithF E.char7 - ------------------------------------------------------------------------------- --- Decimal Encoding ------------------------------------------------------------------------------- - --- Signed integers ------------------- - --- | Decimal encoding of an 'Int8' using the ASCII digits. --- --- e.g. --- --- > toLazyByteString (int8Dec 42) = "42" --- > toLazyByteString (int8Dec (-1)) = "-1" --- -{-# INLINE int8Dec #-} -int8Dec :: Int8 -> Builder -int8Dec = E.encodeWithB E.int8Dec - --- | Decimal encoding of an 'Int16' using the ASCII digits. -{-# INLINE int16Dec #-} -int16Dec :: Int16 -> Builder -int16Dec = E.encodeWithB E.int16Dec - --- | Decimal encoding of an 'Int32' using the ASCII digits. -{-# INLINE int32Dec #-} -int32Dec :: Int32 -> Builder -int32Dec = E.encodeWithB E.int32Dec - --- | Decimal encoding of an 'Int64' using the ASCII digits. -{-# INLINE int64Dec #-} -int64Dec :: Int64 -> Builder -int64Dec = E.encodeWithB E.int64Dec - --- | Decimal encoding of an 'Int' using the ASCII digits. -{-# INLINE intDec #-} -intDec :: Int -> Builder -intDec = E.encodeWithB E.intDec - --- | /Currently slow./ Decimal encoding of an 'Integer' using the ASCII digits. -{-# INLINE integerDec #-} -integerDec :: Integer -> Builder -integerDec = string7 . show - - --- Unsigned integers --------------------- - --- | Decimal encoding of a 'Word8' using the ASCII digits. -{-# INLINE word8Dec #-} -word8Dec :: Word8 -> Builder -word8Dec = E.encodeWithB E.word8Dec - --- | Decimal encoding of a 'Word16' using the ASCII digits. -{-# INLINE word16Dec #-} -word16Dec :: Word16 -> Builder -word16Dec = E.encodeWithB E.word16Dec - --- | Decimal encoding of a 'Word32' using the ASCII digits. -{-# INLINE word32Dec #-} -word32Dec :: Word32 -> Builder -word32Dec = E.encodeWithB E.word32Dec - --- | Decimal encoding of a 'Word64' using the ASCII digits. -{-# INLINE word64Dec #-} -word64Dec :: Word64 -> Builder -word64Dec = E.encodeWithB E.word64Dec - --- | Decimal encoding of a 'Word' using the ASCII digits. -{-# INLINE wordDec #-} -wordDec :: Word -> Builder -wordDec = E.encodeWithB E.wordDec - - --- Floating point numbers -------------------------- - --- TODO: Use Bryan O'Sullivan's double-conversion package to speed it up. - --- | /Currently slow./ Decimal encoding of an IEEE 'Float'. -{-# INLINE floatDec #-} -floatDec :: Float -> Builder -floatDec = string7 . show - --- | /Currently slow./ Decimal encoding of an IEEE 'Double'. -{-# INLINE doubleDec #-} -doubleDec :: Double -> Builder -doubleDec = string7 . show - - ------------------------------------------------------------------------------- --- Hexadecimal Encoding ------------------------------------------------------------------------------- - --- without lead ---------------- - --- | Shortest hexadecimal encoding of a 'Word8' using lower-case characters. -{-# INLINE word8Hex #-} -word8Hex :: Word8 -> Builder -word8Hex = E.encodeWithB E.word8Hex - --- | Shortest hexadecimal encoding of a 'Word16' using lower-case characters. -{-# INLINE word16Hex #-} -word16Hex :: Word16 -> Builder -word16Hex = E.encodeWithB E.word16Hex - --- | Shortest hexadecimal encoding of a 'Word32' using lower-case characters. -{-# INLINE word32Hex #-} -word32Hex :: Word32 -> Builder -word32Hex = E.encodeWithB E.word32Hex - --- | Shortest hexadecimal encoding of a 'Word64' using lower-case characters. -{-# INLINE word64Hex #-} -word64Hex :: Word64 -> Builder -word64Hex = E.encodeWithB E.word64Hex - --- | Shortest hexadecimal encoding of a 'Word' using lower-case characters. -{-# INLINE wordHex #-} -wordHex :: Word -> Builder -wordHex = E.encodeWithB E.wordHex - - --- fixed width; leading zeroes ------------------------------- - --- | Encode a 'Int8' using 2 nibbles (hexadecimal digits). -{-# INLINE int8HexFixed #-} -int8HexFixed :: Int8 -> Builder -int8HexFixed = E.encodeWithF E.int8HexFixed - --- | Encode a 'Int16' using 4 nibbles. -{-# INLINE int16HexFixed #-} -int16HexFixed :: Int16 -> Builder -int16HexFixed = E.encodeWithF E.int16HexFixed - --- | Encode a 'Int32' using 8 nibbles. -{-# INLINE int32HexFixed #-} -int32HexFixed :: Int32 -> Builder -int32HexFixed = E.encodeWithF E.int32HexFixed - --- | Encode a 'Int64' using 16 nibbles. -{-# INLINE int64HexFixed #-} -int64HexFixed :: Int64 -> Builder -int64HexFixed = E.encodeWithF E.int64HexFixed - --- | Encode a 'Word8' using 2 nibbles (hexadecimal digits). -{-# INLINE word8HexFixed #-} -word8HexFixed :: Word8 -> Builder -word8HexFixed = E.encodeWithF E.word8HexFixed - --- | Encode a 'Word16' using 4 nibbles. -{-# INLINE word16HexFixed #-} -word16HexFixed :: Word16 -> Builder -word16HexFixed = E.encodeWithF E.word16HexFixed - --- | Encode a 'Word32' using 8 nibbles. -{-# INLINE word32HexFixed #-} -word32HexFixed :: Word32 -> Builder -word32HexFixed = E.encodeWithF E.word32HexFixed - --- | Encode a 'Word64' using 16 nibbles. -{-# INLINE word64HexFixed #-} -word64HexFixed :: Word64 -> Builder -word64HexFixed = E.encodeWithF E.word64HexFixed - --- | Encode an IEEE 'Float' using 8 nibbles. -{-# INLINE floatHexFixed #-} -floatHexFixed :: Float -> Builder -floatHexFixed = E.encodeWithF E.floatHexFixed - --- | Encode an IEEE 'Double' using 16 nibbles. -{-# INLINE doubleHexFixed #-} -doubleHexFixed :: Double -> Builder -doubleHexFixed = E.encodeWithF E.doubleHexFixed - --- | Encode each byte of a 'S.ByteString' using its fixed-width hex encoding. -{-# NOINLINE byteStringHexFixed #-} -- share code -byteStringHexFixed :: S.ByteString -> Builder -byteStringHexFixed = E.encodeByteStringWithF E.word8HexFixed - --- | Encode each byte of a lazy 'L.ByteString' using its fixed-width hex encoding. -{-# NOINLINE lazyByteStringHexFixed #-} -- share code -lazyByteStringHexFixed :: L.ByteString -> Builder -lazyByteStringHexFixed = E.encodeLazyByteStringWithF E.word8HexFixed diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding.hs b/Data/ByteString/Lazy/Builder/BasicEncoding.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding.hs +++ /dev/null @@ -1,804 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{- | Copyright : (c) 2010-2011 Simon Meier - (c) 2010 Jasper van der Jeugt -License : BSD3-style (see LICENSE) -Maintainer : Simon Meier -Portability : GHC - -This module provides the types of fixed-size and bounded-size encodings, - which are the basic building blocks for constructing 'Builder's. -These types are used to achieve - application-specific performance improvements of 'Builder's. - -/Fixed(-size) encodings/ are encodings that always result in a sequence of bytes - of a predetermined, fixed length. -An example for a fixed encoding is the big-endian encoding of a 'Word64', - which always results in exactly 8 bytes. -/Bounded(-size) encodings/ are encodings that always result in a sequence - of bytes that is no larger than a predetermined bound. -An example for a bounded encoding is the UTF-8 encoding of a 'Char', - which results always in less or equal to 4 bytes. -Note that every fixed encoding is also a bounded encoding. -In the following, we therefore only refer to fixed encodings, - where it matters that the resulting sequence of bytes is of a - of a predetermined, fixed length. -Otherwise, we just refer to bounded encodings. - -As said, - the goal of bounded encodings is to improve the performance of 'Builder's. -These improvements stem from making the two - most common steps performed by a 'Builder' more efficient. -We explain these two steps in turn. - -The first most common step is the concatentation of two 'Builder's. -Internally, - concatentation corresponds to function composition. -(Note that 'Builder's can be seen as difference-lists - of buffer-filling functions; - cf. . -) -Function composition is a fast /O(1)/ operation. -However, - we can use bounded encodings to - remove some of these function compositions altoghether, - which is obviously more efficient. - -The second most common step performed by a 'Builder' is to fill a buffer - using a bounded encoding, - which works as follows. -The 'Builder' checks whether there is enough space left to - execute the bounded encoding. -If there is, then the 'Builder' executes the bounded encoding - and calls the next 'Builder' with the updated buffer. -Otherwise, - the 'Builder' signals its driver that it requires a new buffer. -This buffer must be at least as large as the bound of the encoding. -We can use bounded encodings to reduce the number of buffer-free - checks by fusing the buffer-free checks of consecutive - 'Builder's. -We can also use bounded encodings to simplify the control flow - for signalling that a buffer is full by - ensuring that we check first that there is enough space left - and only then decide on how to encode a given value. - -Let us illustrate these improvements on the - CSV-table rendering example from "Data.ByteString.Lazy.Builder". -Its \"hot code\" is the rendering of a table's cells, - which we implement as follows using only the functions from the - 'Builder' API. - -@ -import "Data.ByteString.Lazy.Builder" as B -import "Data.ByteString.Lazy.Builder.ASCII" as B - -renderCell :: Cell -> Builder -renderCell (StringC cs) = renderString cs -renderCell (IntC i) = B.intDec i - -renderString :: String -> Builder -renderString cs = B.charUtf8 \'\"\' \<\> foldMap escape cs \<\> B.charUtf8 \'\"\' - where - escape \'\\\\\' = B.charUtf8 \'\\\\\' \<\> B.charUtf8 \'\\\\\' - escape \'\\\"\' = B.charUtf8 \'\\\\\' \<\> B.charUtf8 \'\\\"\' - escape c = B.charUtf8 c -@ - -Efficient encoding of 'Int's as decimal numbers is performed by @intDec@ - from "Data.ByteString.Lazy.Builder.ASCII". -Optimization potential exists for the escaping of 'String's. -The above implementation has two optimization opportunities. -First, - the buffer-free checks of the 'Builder's for escaping doublequotes - and backslashes can be fused. -Second, - the concatenations performed by 'foldMap' can be eliminated. -The following implementation exploits these optimizations. - -@ -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E -import Data.ByteString.Lazy.Builder.BasicEncoding - ( 'ifB', 'fromF', ('>*<'), ('>$<') ) - -renderString :: String -\> Builder -renderString cs = - B.charUtf8 \'\"\' \<\> E.'encodeListWithB' escape cs \<\> B.charUtf8 \'\"\' - where - escape :: E.'BoundedEncoding' Char - escape = - 'ifB' (== \'\\\\\') (fixed2 (\'\\\\\', \'\\\\\')) $ - 'ifB' (== \'\\\"\') (fixed2 (\'\\\\\', \'\\\"\')) $ - E.'charUtf8' -   - {-\# INLINE fixed2 \#-} - fixed2 x = 'fromF' $ const x '>$<' E.'char7' '>*<' E.'char7' -@ - -The code should be mostly self-explanatory. -The slightly awkward syntax is because the combinators - are written such that the size-bound of the resulting 'BoundedEncoding' - can be computed at compile time. -We also explicitly inline the 'fixed2' encoding, - which encodes a fixed tuple of characters, - to ensure that the bound compuation happens at compile time. -When encoding the following list of 'String's, - the optimized implementation of 'renderString' is two times faster. - -@ -maxiStrings :: [String] -maxiStrings = take 1000 $ cycle [\"hello\", \"\\\"1\\\"\", \"λ-wörld\"] -@ - -Most of the performance gain stems from using 'encodeListWithB', - which encodes a list of values from left-to-right with a - 'BoundedEncoding'. -It exploits the 'Builder' internals to avoid unnecessary function - compositions (i.e., concatentations). -In the future, - we would expect the compiler to perform the optimizations - implemented in 'encodeListWithB'. -However, - it seems that the code is currently to complicated for the - compiler to see through. -Therefore, - we provide the 'BoundedEncoding' escape hatch, - which allows data structures to provide very efficient encoding traversals, - like 'encodeListWithB' for lists. - -Note that 'BoundedEncoding's are a bit verbose, but quite versatile. -Here is an example of a 'BoundedEncoding' for combined HTML escapng and -UTF-8 encoding. -It exploits that the escaped character with the maximal Unicode - codepoint is \'>\'. - -@ -{-\# INLINE charUtf8HtmlEscaped \#-} -charUtf8HtmlEscaped :: E.BoundedEncoding Char -charUtf8HtmlEscaped = - 'ifB' (> \'\>\' ) E.'charUtf8' $ - 'ifB' (== \'\<\' ) (fixed4 (\'&\',(\'l\',(\'t\',\';\')))) $ -- < - 'ifB' (== \'\>\' ) (fixed4 (\'&\',(\'g\',(\'t\',\';\')))) $ -- > - 'ifB' (== \'&\' ) (fixed5 (\'&\',(\'a\',(\'m\',(\'p\',\';\'))))) $ -- & - 'ifB' (== \'\"\' ) (fixed5 (\'&\',(\'\#\',(\'3\',(\'4\',\';\'))))) $ -- &\#34; - 'ifB' (== \'\\\'\') (fixed5 (\'&\',(\'\#\',(\'3\',(\'9\',\';\'))))) $ -- &\#39; - ('fromF' E.'char7') -- fallback for 'Char's smaller than \'\>\' - where - {-\# INLINE fixed4 \#-} - fixed4 x = 'fromF' $ const x '>$<' - E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7 -   - {-\# INLINE fixed5 \#-} - fixed5 x = 'fromF' $ const x '>$<' - E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7 -@ - -This module currently does not expose functions that require the special - properties of fixed-size encodings. -They are useful for prefixing 'Builder's with their size or for - implementing chunked encodings. -We will expose the corresponding functions in future releases of this - library. --} - - - -{- --- --- --- A /bounded encoding/ is an encoding that never results in a sequence --- longer than some fixed number of bytes. This number of bytes must be --- independent of the value being encoded. Typical examples of bounded --- encodings are the big-endian encoding of a 'Word64', which results always --- in exactly 8 bytes, or the UTF-8 encoding of a 'Char', which results always --- in less or equal to 4 bytes. --- --- Typically, encodings are implemented efficiently by allocating a buffer (an --- array of bytes) and repeatedly executing the following two steps: (1) --- writing to the buffer until it is full and (2) handing over the filled part --- to the consumer of the encoded value. Step (1) is where bounded encodings --- are used. We must use a bounded encoding, as we must check that there is --- enough free space /before/ actually writing to the buffer. --- --- In term of expressivity, it would be sufficient to construct all encodings --- from the single bounded encoding that encodes a 'Word8' as-is. However, --- this is not sufficient in terms of efficiency. It results in unnecessary --- buffer-full checks and it complicates the program-flow for writing to the --- buffer, as buffer-full checks are interleaved with analyzing the value to be --- encoded (e.g., think about the program-flow for UTF-8 encoding). This has a --- significant effect on overall encoding performance, as encoding primitive --- Haskell values such as 'Word8's or 'Char's lies at the heart of every --- encoding implementation. --- --- The bounded 'Encoding's provided by this module remove this performance --- problem. Intuitively, they consist of a tuple of the bound on the maximal --- number of bytes written and the actual implementation of the encoding as a --- function that modifies a mutable buffer. Hence when executing a bounded --- 'Encoding', the buffer-full check can be done once before the actual writing --- to the buffer. The provided 'Encoding's also take care to implement the --- actual writing to the buffer efficiently. Moreover, combinators are --- provided to construct new bounded encodings from the provided ones. --- --- A typical example for using the combinators is a bounded 'Encoding' that --- combines escaping the ' and \\ characters with UTF-8 encoding. More --- precisely, the escaping to be done is the one implemented by the following --- @escape@ function. --- --- > escape :: Char -> [Char] --- > escape '\'' = "\\'" --- > escape '\\' = "\\\\" --- > escape c = [c] --- --- The bounded 'Encoding' that combines this escaping with UTF-8 encoding is --- the following. --- --- > import Data.ByteString.Lazy.Builder.BasicEncoding.Utf8 (char) --- > --- > {-# INLINE escapeChar #-} --- > escapeUtf8 :: BoundedEncoding Char --- > escapeUtf8 = --- > encodeIf ('\'' ==) (char <#> char #. const ('\\','\'')) $ --- > encodeIf ('\\' ==) (char <#> char #. const ('\\','\\')) $ --- > char --- --- The definition of 'escapeUtf8' is more complicated than 'escape', because --- the combinators ('encodeIf', 'encodePair', '#.', and 'char') used in --- 'escapeChar' compute both the bound on the maximal number of bytes written --- (8 for 'escapeUtf8') as well as the low-level buffer manipulation required --- to implement the encoding. Bounded 'Encoding's should always be inlined. --- Otherwise, the compiler cannot compute the bound on the maximal number of --- bytes written at compile-time. Without inlinining, it would also fail to --- optimize the constant encoding of the escape characters in the above --- example. Functions that execute bounded 'Encoding's also perform --- suboptimally, if the definition of the bounded 'Encoding' is not inlined. --- Therefore we add an 'INLINE' pragma to 'escapeUtf8'. --- --- Currently, the only library that executes bounded 'Encoding's is the --- 'bytestring' library (). It --- uses bounded 'Encoding's to implement most of its lazy bytestring builders. --- Executing a bounded encoding should be done using the corresponding --- functions in the lazy bytestring builder 'Extras' module. --- --- TODO: Merge with explanation/example below --- --- Bounded 'E.Encoding's abstract encodings of Haskell values that can be implemented by --- writing a bounded-size sequence of bytes directly to memory. They are --- lifted to conversions from Haskell values to 'Builder's by wrapping them --- with a bound-check. The compiler can implement this bound-check very --- efficiently (i.e, a single comparison of the difference of two pointers to a --- constant), because the bound of a 'E.Encoding' is always independent of the --- value being encoded and, in most cases, a literal constant. --- --- 'E.Encoding's are the primary means for defining conversion functions from --- primitive Haskell values to 'Builder's. Most 'Builder' constructors --- provided by this library are implemented that way. --- 'E.Encoding's are also used to construct conversions that exploit the internal --- representation of data-structures. --- --- For example, 'encodeByteStringWith' works directly on the underlying byte --- array and uses some tricks to reduce the number of variables in its inner --- loop. Its efficiency is exploited for implementing the @filter@ and @map@ --- functions in "Data.ByteString.Lazy" as --- --- > import qualified Codec.Bounded.Encoding as E --- > --- > filter :: (Word8 -> Bool) -> ByteString -> ByteString --- > filter p = toLazyByteString . encodeLazyByteStringWithB write --- > where --- > write = E.encodeIf p E.word8 E.emptyEncoding --- > --- > map :: (Word8 -> Word8) -> ByteString -> ByteString --- > map f = toLazyByteString . encodeLazyByteStringWithB (E.word8 E.#. f) --- --- Compared to earlier versions of @filter@ and @map@ on lazy 'L.ByteString's, --- these versions use a more efficient inner loop and have the additional --- advantage that they always result in well-chunked 'L.ByteString's; i.e, they --- also perform automatic defragmentation. --- --- We can also use 'E.Encoding's to improve the efficiency of the following --- 'renderString' function from our UTF-8 CSV table encoding example in --- "Data.ByteString.Lazy.Builder". --- --- > renderString :: String -> Builder --- > renderString cs = charUtf8 '"' <> foldMap escape cs <> charUtf8 '"' --- > where --- > escape '\\' = charUtf8 '\\' <> charUtf8 '\\' --- > escape '\"' = charUtf8 '\\' <> charUtf8 '\"' --- > escape c = charUtf8 c --- --- The idea is to save on 'mappend's by implementing a 'E.Encoding' that escapes --- characters and using 'encodeListWith', which implements writing a list of --- values with a tighter inner loop and no 'mappend'. --- --- > import Data.ByteString.Lazy.Builder.Extras -- assume these three --- > import Codec.Bounded.Encoding -- imports are present --- > ( BoundedEncoding, encodeIf, (<#>), (#.) ) --- > import Data.ByteString.Lazy.Builder.BasicEncoding.Utf8 (char) --- > --- > renderString :: String -> Builder --- > renderString cs = --- > charUtf8 '"' <> encodeListWithB escapedUtf8 cs <> charUtf8 '"' --- > where --- > escapedUtf8 :: BoundedEncoding Char --- > escapedUtf8 = --- > encodeIf (== '\\') (char <#> char #. const ('\\', '\\')) $ --- > encodeIf (== '\"') (char <#> char #. const ('\\', '\"')) $ --- > char --- --- This 'Builder' considers a buffer with less than 8 free bytes as full. As --- all functions are inlined, the compiler is able to optimize the constant --- 'E.Encoding's as two sequential 'poke's. Compared to the first implementation of --- 'renderString' this implementation is 1.7x faster. --- --} -{- -Internally, 'Builder's are buffer-fill operations that are -given a continuation buffer-fill operation and a buffer-range to be filled. -A 'Builder' first checks if the buffer-range is large enough. If that's -the case, the 'Builder' writes the sequences of bytes to the buffer and -calls its continuation. Otherwise, it returns a signal that it requires a -new buffer together with a continuation to be called on this new buffer. -Ignoring the rare case of a full buffer-range, the execution cost of a -'Builder' consists of three parts: - - 1. The time taken to read the parameters; i.e., the buffer-fill - operation to call after the 'Builder' is done and the buffer-range to - fill. - - 2. The time taken to check for the size of the buffer-range. - - 3. The time taken for the actual encoding. - -We can reduce cost (1) by ensuring that fewer buffer-fill function calls are -required. We can reduce cost (2) by fusing buffer-size checks of sequential -writes. For example, when escaping a 'String' using 'renderString', it would -be sufficient to check before encoding a character that at least 8 bytes are -free. We can reduce cost (3) by implementing better primitive 'Builder's. -For example, 'renderCell' builds an intermediate list containing the decimal -representation of an 'Int'. Implementing a direct decimal encoding of 'Int's -to memory would be more efficient, as it requires fewer buffer-size checks -and less allocation. It is also a planned extension of this library. - -The first two cost reductions are supported for user code through functions -in "Data.ByteString.Lazy.Builder.Extras". There, we continue the above example -and drop the generation time to 0.8ms by implementing 'renderString' more -cleverly. The third reduction requires meddling with the internals of -'Builder's and is not recomended in code outside of this library. However, -patches to this library are very welcome. --} -module Data.ByteString.Lazy.Builder.BasicEncoding ( - - -- * Fixed-size encodings - FixedEncoding - - -- ** Combinators - -- | The combinators for 'FixedEncoding's are implemented such that the 'size' - -- of the resulting 'FixedEncoding' is computed at compile time. - , emptyF - , pairF - , contramapF - - -- ** Builder construction - -- | In terms of expressivity, the function 'encodeWithF' would be sufficient - -- for constructing 'Builder's from 'FixedEncoding's. The fused variants of - -- this function are provided because they allow for more efficient - -- implementations. Our compilers are just not smart enough yet; and for some - -- of the employed optimizations (see the code of 'encodeByteStringWithF') - -- they will very likely never be. - -- - -- Note that functions marked with \"/Heavy inlining./\" are forced to be - -- inlined because they must be specialized for concrete encodings, - -- but are rather heavy in terms of code size. We recommend to define a - -- top-level function for every concrete instantiation of such a function in - -- order to share its code. A typical example is the function - -- 'byteStringHexFixed' from "Data.ByteString.Lazy.Builder.ASCII", which is - -- implemented as follows. - -- - -- @ - -- byteStringHexFixed :: S.ByteString -> Builder - -- byteStringHexFixed = 'encodeByteStringWithF' 'word8HexFixed' - -- @ - -- - , encodeWithF - , encodeListWithF - , encodeUnfoldrWithF - - , encodeByteStringWithF - , encodeLazyByteStringWithF - - -- * Bounded-size encodings - - , BoundedEncoding - - -- ** Combinators - -- | The combinators for 'BoundedEncoding's are implemented such that the - -- 'sizeBound' of the resulting 'BoundedEncoding' is computed at compile time. - , fromF - , emptyB - , pairB - , eitherB - , ifB - , contramapB - - -- | We provide overloaded operators for some of the above combinators to - -- allow for a more convenient syntax. We do not export their corresponding, - -- as we they are used for overloading only and should not be extended by - -- the user of this library. We plan to use the @contravariant@ library - -- once it is part of the - -- Haskell platform. - , (>*<) - , (>$<) - - -- ** Builder construction - , encodeWithB - , encodeListWithB - , encodeUnfoldrWithB - - , encodeByteStringWithB - , encodeLazyByteStringWithB - - -- * Standard encodings of Haskell values - - , module Data.ByteString.Lazy.Builder.BasicEncoding.Binary - - -- ** Character encodings - , module Data.ByteString.Lazy.Builder.BasicEncoding.ASCII - - -- *** ISO/IEC 8859-1 (Char8) - -- | The ISO/IEC 8859-1 encoding is an 8-bit encoding often known as Latin-1. - -- The /Char8/ encoding implemented here works by truncating the Unicode - -- codepoint to 8-bits and encoding them as a single byte. For the codepoints - -- 0-255 this corresponds to the ISO/IEC 8859-1 encoding. Note that the - -- Char8 encoding is equivalent to the ASCII encoding on the Unicode - -- codepoints 0-127. Hence, functions such as 'intDec' can also be used for - -- encoding 'Int's as a decimal number with Char8 encoded characters. - , char8 - - -- *** UTF-8 - -- | The UTF-8 encoding can encode all Unicode codepoints. - -- It is equivalent to the ASCII encoding on the Unicode codepoints 0-127. - -- Hence, functions such as 'intDec' can also be used for encoding 'Int's as - -- a decimal number with UTF-8 encoded characters. - , charUtf8 - - -- * Testing support - -- | The following four functions are intended for testing use - -- only. They are /not/ efficient. Basic encodings are efficently executed by - -- creating 'Builder's from them using the @encodeXXX@ functions explained at - -- the top of this module. - - , evalF - , evalB - - , showF - , showB - - ) where - -import Data.ByteString.Lazy.Builder.Internal -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Base16 (lowerTable, encode4_as_8) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy.Internal as L - -import Data.Monoid -import Data.List (unfoldr) -- HADDOCK ONLY -import Data.Char (chr, ord) -import Control.Monad ((<=<), unless) - -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal hiding (size, sizeBound) -import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Internal as I (size, sizeBound) -import Data.ByteString.Lazy.Builder.BasicEncoding.Binary -import Data.ByteString.Lazy.Builder.BasicEncoding.ASCII - -#if MIN_VERSION_base(4,4,0) -import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import System.IO.Unsafe (unsafePerformIO) -#else -import Foreign -#endif - ------------------------------------------------------------------------------- --- Creating Builders from bounded encodings ------------------------------------------------------------------------------- - --- | Encode a value with a 'FixedEncoding'. -{-# INLINE encodeWithF #-} -encodeWithF :: FixedEncoding a -> (a -> Builder) -encodeWithF = encodeWithB . toB - --- | Encode a list of values from left-to-right with a 'FixedEncoding'. -{-# INLINE encodeListWithF #-} -encodeListWithF :: FixedEncoding a -> ([a] -> Builder) -encodeListWithF = encodeListWithB . toB - --- | Encode a list of values represented as an 'unfoldr' with a 'FixedEncoding'. -{-# INLINE encodeUnfoldrWithF #-} -encodeUnfoldrWithF :: FixedEncoding b -> (a -> Maybe (b, a)) -> a -> Builder -encodeUnfoldrWithF = encodeUnfoldrWithB . toB - --- | /Heavy inlining./ Encode all bytes of a strict 'S.ByteString' from --- left-to-right with a 'FixedEncoding'. This function is quite versatile. For --- example, we can use it to construct a 'Builder' that maps every byte before --- copying it to the buffer to be filled. --- --- > mapToBuilder :: (Word8 -> Word8) -> S.ByteString -> Builder --- > mapToBuilder f = encodeByteStringWithF (contramapF f word8) --- --- We can also use it to hex-encode a strict 'S.ByteString' as shown by the --- 'byteStringHexFixed' example above. -{-# INLINE encodeByteStringWithF #-} -encodeByteStringWithF :: FixedEncoding Word8 -> (S.ByteString -> Builder) -encodeByteStringWithF = encodeByteStringWithB . toB - --- | /Heavy inlining./ Encode all bytes of a lazy 'L.ByteString' from --- left-to-right with a 'FixedEncoding'. -{-# INLINE encodeLazyByteStringWithF #-} -encodeLazyByteStringWithF :: FixedEncoding Word8 -> (L.ByteString -> Builder) -encodeLazyByteStringWithF = encodeLazyByteStringWithB . toB - --- IMPLEMENTATION NOTE: Sadly, 'encodeListWith' cannot be used for foldr/build --- fusion. Its performance relies on hoisting several variables out of the --- inner loop. That's not possible when writing 'encodeListWith' as a 'foldr'. --- If we had stream fusion for lists, then we could fuse 'encodeListWith', as --- 'encodeWithStream' can keep control over the execution. - - --- | Create a 'Builder' that encodes values with the given 'Encoding'. --- --- We rewrite consecutive uses of 'encodeWith' such that the bound-checks are --- fused. For example, --- --- > encodeWithB (word32 c1) `mappend` encodeWithB (word32 c2) --- --- is rewritten such that the resulting 'Builder' checks only once, if ther are --- at 8 free bytes, instead of checking twice, if there are 4 free bytes. This --- optimization is not observationally equivalent in a strict sense, as it --- influences the boundaries of the generated chunks. However, for a user of --- this library it is observationally equivalent, as chunk boundaries of a lazy --- 'L.ByteString' can only be observed through the internal interface. --- Morevoer, we expect that all 'Encoding's write much fewer than 4kb (the --- default short buffer size). Hence, it is safe to ignore the additional --- memory spilled due to the more agressive buffer wrapping introduced by this --- optimization. --- -{-# INLINE[1] encodeWithB #-} -encodeWithB :: BoundedEncoding a -> (a -> Builder) -encodeWithB w = - mkBuilder - where - bound = I.sizeBound w - mkBuilder x = builder step - where - step k (BufferRange op ope) - | op `plusPtr` bound <= ope = do - op' <- runB w x op - let !br' = BufferRange op' ope - k br' - | otherwise = return $ bufferFull bound op (step k) - -{-# RULES - -"append/encodeWithB" forall w1 w2 x1 x2. - append (encodeWithB w1 x1) (encodeWithB w2 x2) - = encodeWithB (pairB w1 w2) (x1, x2) - -"append/encodeWithB/assoc_r" forall w1 w2 x1 x2 b. - append (encodeWithB w1 x1) (append (encodeWithB w2 x2) b) - = append (encodeWithB (pairB w1 w2) (x1, x2)) b - -"append/encodeWithB/assoc_l" forall w1 w2 x1 x2 b. - append (append b (encodeWithB w1 x1)) (encodeWithB w2 x2) - = append b (encodeWithB (pairB w1 w2) (x1, x2)) - #-} - --- TODO: The same rules for 'putBuilder (..) >> putBuilder (..)' - --- | Create a 'Builder' that encodes a list of values consecutively using an --- 'Encoding'. This function is more efficient than the canonical --- --- > filter p = --- > B.toLazyByteString . --- > E.encodeLazyByteStringWithF (E.ifF p E.word8) E.emptyF) --- > --- --- > mconcat . map (encodeWithB w) --- --- or --- --- > foldMap (encodeWithB w) --- --- because it moves several variables out of the inner loop. -{-# INLINE encodeListWithB #-} -encodeListWithB :: BoundedEncoding a -> [a] -> Builder -encodeListWithB w = - makeBuilder - where - bound = I.sizeBound w - makeBuilder xs0 = builder $ step xs0 - where - step xs1 k !(BufferRange op0 ope0) = go xs1 op0 - where - go [] !op = do - let !br' = BufferRange op ope0 - k br' - - go xs@(x':xs') !op - | op `plusPtr` bound <= ope0 = do - !op' <- runB w x' op - go xs' op' - | otherwise = return $ bufferFull bound op (step xs k) - --- TODO: Add 'foldMap/encodeWith' its variants --- TODO: Ensure rewriting 'encodeWithB w . f = encodeWithB (w #. f)' - --- | Create a 'Builder' that encodes a sequence generated from a seed value --- using an 'Encoding'. -{-# INLINE encodeUnfoldrWithB #-} -encodeUnfoldrWithB :: BoundedEncoding b -> (a -> Maybe (b, a)) -> a -> Builder -encodeUnfoldrWithB w = - makeBuilder - where - bound = I.sizeBound w - makeBuilder f x0 = builder $ step x0 - where - step x1 !k = fill x1 - where - fill x !(BufferRange pf0 pe0) = go (f x) pf0 - where - go !Nothing !pf = do - let !br' = BufferRange pf pe0 - k br' - go !(Just (y, x')) !pf - | pf `plusPtr` bound <= pe0 = do - !pf' <- runB w y pf - go (f x') pf' - | otherwise = return $ bufferFull bound pf $ - \(BufferRange pfNew peNew) -> do - !pfNew' <- runB w y pfNew - fill x' (BufferRange pfNew' peNew) - --- | Create a 'Builder' that encodes each 'Word8' of a strict 'S.ByteString' --- using an 'Encoding'. For example, we can write a 'Builder' that filters --- a strict 'S.ByteString' as follows. --- --- > import Codec.Bounded.Encoding as E (encodeIf, word8, encodeNothing) --- --- > filterBS p = E.encodeIf p E.word8 E.encodeNothing --- -{-# INLINE encodeByteStringWithB #-} -encodeByteStringWithB :: BoundedEncoding Word8 -> S.ByteString -> Builder -encodeByteStringWithB w = - \bs -> builder $ step bs - where - bound = I.sizeBound w - step (S.PS ifp ioff isize) !k = - goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff) - where - !ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize) - goBS !ip0 !br@(BufferRange op0 ope) - | ip0 >= ipe = do - touchForeignPtr ifp -- input buffer consumed - k br - - | op0 `plusPtr` bound < ope = - goPartial (ip0 `plusPtr` min outRemaining inpRemaining) - - | otherwise = return $ bufferFull bound op0 (goBS ip0) - where - outRemaining = (ope `minusPtr` op0) `div` bound - inpRemaining = ipe `minusPtr` ip0 - - goPartial !ipeTmp = go ip0 op0 - where - go !ip !op - | ip < ipeTmp = do - x <- peek ip - op' <- runB w x op - go (ip `plusPtr` 1) op' - | otherwise = - goBS ip (BufferRange op ope) - --- | Chunk-wise application of 'encodeByteStringWith'. -{-# INLINE encodeLazyByteStringWithB #-} -encodeLazyByteStringWithB :: BoundedEncoding Word8 -> L.ByteString -> Builder -encodeLazyByteStringWithB w = - L.foldrChunks (\x b -> encodeByteStringWithB w x `mappend` b) mempty - - ------------------------------------------------------------------------------- --- Char8 encoding ------------------------------------------------------------------------------- - --- | Char8 encode a 'Char'. -{-# INLINE char8 #-} -char8 :: FixedEncoding Char -char8 = (fromIntegral . ord) >$< word8 - - ------------------------------------------------------------------------------- --- UTF-8 encoding ------------------------------------------------------------------------------- - --- | UTF-8 encode a 'Char'. -{-# INLINE charUtf8 #-} -charUtf8 :: BoundedEncoding Char -charUtf8 = boundedEncoding 4 (encodeCharUtf8 f1 f2 f3 f4) - where - pokeN n io op = io op >> return (op `plusPtr` n) - - f1 x1 = pokeN 1 $ \op -> do pokeByteOff op 0 x1 - - f2 x1 x2 = pokeN 2 $ \op -> do pokeByteOff op 0 x1 - pokeByteOff op 1 x2 - - f3 x1 x2 x3 = pokeN 3 $ \op -> do pokeByteOff op 0 x1 - pokeByteOff op 1 x2 - pokeByteOff op 2 x3 - - f4 x1 x2 x3 x4 = pokeN 4 $ \op -> do pokeByteOff op 0 x1 - pokeByteOff op 1 x2 - pokeByteOff op 2 x3 - pokeByteOff op 3 x4 - --- | Encode a Unicode character to another datatype, using UTF-8. This function --- acts as an abstract way of encoding characters, as it is unaware of what --- needs to happen with the resulting bytes: you have to specify functions to --- deal with those. --- -{-# INLINE encodeCharUtf8 #-} -encodeCharUtf8 :: (Word8 -> a) -- ^ 1-byte UTF-8 - -> (Word8 -> Word8 -> a) -- ^ 2-byte UTF-8 - -> (Word8 -> Word8 -> Word8 -> a) -- ^ 3-byte UTF-8 - -> (Word8 -> Word8 -> Word8 -> Word8 -> a) -- ^ 4-byte UTF-8 - -> Char -- ^ Input 'Char' - -> a -- ^ Result -encodeCharUtf8 f1 f2 f3 f4 c = case ord c of - x | x <= 0x7F -> f1 $ fromIntegral x - | x <= 0x07FF -> - let x1 = fromIntegral $ (x `shiftR` 6) + 0xC0 - x2 = fromIntegral $ (x .&. 0x3F) + 0x80 - in f2 x1 x2 - | x <= 0xFFFF -> - let x1 = fromIntegral $ (x `shiftR` 12) + 0xE0 - x2 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 - x3 = fromIntegral $ (x .&. 0x3F) + 0x80 - in f3 x1 x2 x3 - | otherwise -> - let x1 = fromIntegral $ (x `shiftR` 18) + 0xF0 - x2 = fromIntegral $ ((x `shiftR` 12) .&. 0x3F) + 0x80 - x3 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 - x4 = fromIntegral $ (x .&. 0x3F) + 0x80 - in f4 x1 x2 x3 x4 - - ------------------------------------------------------------------------------- --- Testing encodings ------------------------------------------------------------------------------- - --- | /For testing use only./ Evaluate a 'FixedEncoding' on a given value. -evalF :: FixedEncoding a -> a -> [Word8] -evalF fe = S.unpack . S.unsafeCreate (I.size fe) . runF fe - --- | /For testing use only./ Evaluate a 'BoundedEncoding' on a given value. -evalB :: BoundedEncoding a -> a -> [Word8] -evalB be x = S.unpack $ unsafePerformIO $ - S.createAndTrim (I.sizeBound be) $ \op -> do - op' <- runB be x op - return (op' `minusPtr` op) - --- | /For testing use only./ Show the result of a 'FixedEncoding' of a given --- value as a 'String' by interpreting the resulting bytes as Unicode --- codepoints. -showF :: FixedEncoding a -> a -> String -showF fe = map (chr . fromIntegral) . evalF fe - --- | /For testing use only./ Show the result of a 'BoundedEncoding' of a given --- value as a 'String' by interpreting the resulting bytes as Unicode --- codepoints. -showB :: BoundedEncoding a -> a -> String -showB be = map (chr . fromIntegral) . evalB be - - diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/ASCII.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/ASCII.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding/ASCII.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface #-} --- | Copyright : (c) 2010 Jasper Van der Jeugt --- (c) 2010 - 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC --- --- Encodings using ASCII encoded Unicode characters. --- -module Data.ByteString.Lazy.Builder.BasicEncoding.ASCII - ( - - -- *** ASCII - char7 - - -- **** Decimal numbers - -- | Decimal encoding of numbers using ASCII encoded characters. - , int8Dec - , int16Dec - , int32Dec - , int64Dec - , intDec - - , word8Dec - , word16Dec - , word32Dec - , word64Dec - , wordDec - - {- - -- These are the functions currently provided by Bryan O'Sullivans - -- double-conversion library. - -- - -- , float - -- , floatWith - -- , double - -- , doubleWith - -} - - -- **** Hexadecimal numbers - - -- | Encoding positive integers as hexadecimal numbers using lower-case - -- ASCII characters. The shortest possible representation is used. For - -- example, - -- - -- > showB word16Hex 0x0a10 = "a10" - -- - -- Note that there is no support for using upper-case characters. Please - -- contact the maintainer if your application cannot work without - -- hexadecimal encodings that use upper-case characters. - -- - , word8Hex - , word16Hex - , word32Hex - , word64Hex - , wordHex - - -- **** Fixed-width hexadecimal numbers - -- - -- | Encoding the bytes of fixed-width types as hexadecimal - -- numbers using lower-case ASCII characters. For example, - -- - -- > showF word16HexFixed 0x0a10 = "0a10" - -- - , int8HexFixed - , int16HexFixed - , int32HexFixed - , int64HexFixed - , word8HexFixed - , word16HexFixed - , word32HexFixed - , word64HexFixed - , floatHexFixed - , doubleHexFixed - - ) where - -import Data.ByteString.Lazy.Builder.BasicEncoding.Binary -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Floating -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Base16 -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts - -import Data.Char (ord) - -import Foreign -import Foreign.C.Types - --- | Encode the least 7-bits of a 'Char' using the ASCII encoding. -{-# INLINE char7 #-} -char7 :: FixedEncoding Char -char7 = (\c -> fromIntegral $ ord c .&. 0x7f) >$< word8 - - ------------------------------------------------------------------------------- --- Decimal Encoding ------------------------------------------------------------------------------- - --- Signed integers ------------------- - -foreign import ccall unsafe "static _hs_bytestring_int_dec" c_int_dec - :: CInt -> Ptr Word8 -> IO (Ptr Word8) - -foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec" c_long_long_int_dec - :: CLLong -> Ptr Word8 -> IO (Ptr Word8) - -{-# INLINE encodeIntDecimal #-} -encodeIntDecimal :: Integral a => Int -> BoundedEncoding a -encodeIntDecimal bound = boundedEncoding bound $ c_int_dec . fromIntegral - --- | Decimal encoding of an 'Int8'. -{-# INLINE int8Dec #-} -int8Dec :: BoundedEncoding Int8 -int8Dec = encodeIntDecimal 4 - --- | Decimal encoding of an 'Int16'. -{-# INLINE int16Dec #-} -int16Dec :: BoundedEncoding Int16 -int16Dec = encodeIntDecimal 6 - - --- | Decimal encoding of an 'Int32'. -{-# INLINE int32Dec #-} -int32Dec :: BoundedEncoding Int32 -int32Dec = encodeIntDecimal 11 - --- | Decimal encoding of an 'Int64'. -{-# INLINE int64Dec #-} -int64Dec :: BoundedEncoding Int64 -int64Dec = boundedEncoding 20 $ c_long_long_int_dec . fromIntegral - --- | Decimal encoding of an 'Int'. -{-# INLINE intDec #-} -intDec :: BoundedEncoding Int -intDec = caseWordSize_32_64 - (fromIntegral >$< int32Dec) - (fromIntegral >$< int64Dec) - - --- Unsigned integers --------------------- - -foreign import ccall unsafe "static _hs_bytestring_uint_dec" c_uint_dec - :: CUInt -> Ptr Word8 -> IO (Ptr Word8) - -foreign import ccall unsafe "static _hs_bytestring_long_long_uint_dec" c_long_long_uint_dec - :: CULLong -> Ptr Word8 -> IO (Ptr Word8) - -{-# INLINE encodeWordDecimal #-} -encodeWordDecimal :: Integral a => Int -> BoundedEncoding a -encodeWordDecimal bound = boundedEncoding bound $ c_uint_dec . fromIntegral - --- | Decimal encoding of a 'Word8'. -{-# INLINE word8Dec #-} -word8Dec :: BoundedEncoding Word8 -word8Dec = encodeWordDecimal 3 - --- | Decimal encoding of a 'Word16'. -{-# INLINE word16Dec #-} -word16Dec :: BoundedEncoding Word16 -word16Dec = encodeWordDecimal 5 - --- | Decimal encoding of a 'Word32'. -{-# INLINE word32Dec #-} -word32Dec :: BoundedEncoding Word32 -word32Dec = encodeWordDecimal 10 - --- | Decimal encoding of a 'Word64'. -{-# INLINE word64Dec #-} -word64Dec :: BoundedEncoding Word64 -word64Dec = boundedEncoding 20 $ c_long_long_uint_dec . fromIntegral - --- | Decimal encoding of a 'Word'. -{-# INLINE wordDec #-} -wordDec :: BoundedEncoding Word -wordDec = caseWordSize_32_64 - (fromIntegral >$< word32Dec) - (fromIntegral >$< word64Dec) - ------------------------------------------------------------------------------- --- Hexadecimal Encoding ------------------------------------------------------------------------------- - --- without lead ---------------- - -foreign import ccall unsafe "static _hs_bytestring_uint_hex" c_uint_hex - :: CUInt -> Ptr Word8 -> IO (Ptr Word8) - -foreign import ccall unsafe "static _hs_bytestring_long_long_uint_hex" c_long_long_uint_hex - :: CULLong -> Ptr Word8 -> IO (Ptr Word8) - -{-# INLINE encodeWordHex #-} -encodeWordHex :: forall a. (Storable a, Integral a) => BoundedEncoding a -encodeWordHex = - boundedEncoding (2 * sizeOf (undefined :: a)) $ c_uint_hex . fromIntegral - --- | Hexadecimal encoding of a 'Word8'. -{-# INLINE word8Hex #-} -word8Hex :: BoundedEncoding Word8 -word8Hex = encodeWordHex - --- | Hexadecimal encoding of a 'Word16'. -{-# INLINE word16Hex #-} -word16Hex :: BoundedEncoding Word16 -word16Hex = encodeWordHex - --- | Hexadecimal encoding of a 'Word32'. -{-# INLINE word32Hex #-} -word32Hex :: BoundedEncoding Word32 -word32Hex = encodeWordHex - --- | Hexadecimal encoding of a 'Word64'. -{-# INLINE word64Hex #-} -word64Hex :: BoundedEncoding Word64 -word64Hex = boundedEncoding 16 $ c_long_long_uint_hex . fromIntegral - --- | Hexadecimal encoding of a 'Word'. -{-# INLINE wordHex #-} -wordHex :: BoundedEncoding Word -wordHex = caseWordSize_32_64 - (fromIntegral >$< word32Hex) - (fromIntegral >$< word64Hex) - - --- fixed width; leading zeroes ------------------------------- - --- | Encode a 'Word8' using 2 nibbles (hexadecimal digits). -{-# INLINE word8HexFixed #-} -word8HexFixed :: FixedEncoding Word8 -word8HexFixed = fixedEncoding 2 $ - \x op -> poke (castPtr op) =<< encode8_as_16h lowerTable x - --- | Encode a 'Word16' using 4 nibbles. -{-# INLINE word16HexFixed #-} -word16HexFixed :: FixedEncoding Word16 -word16HexFixed = - (\x -> (fromIntegral $ x `shiftr_w16` 8, fromIntegral x)) - >$< pairF word8HexFixed word8HexFixed - --- | Encode a 'Word32' using 8 nibbles. -{-# INLINE word32HexFixed #-} -word32HexFixed :: FixedEncoding Word32 -word32HexFixed = - (\x -> (fromIntegral $ x `shiftr_w32` 16, fromIntegral x)) - >$< pairF word16HexFixed word16HexFixed --- | Encode a 'Word64' using 16 nibbles. -{-# INLINE word64HexFixed #-} -word64HexFixed :: FixedEncoding Word64 -word64HexFixed = - (\x -> (fromIntegral $ x `shiftr_w64` 32, fromIntegral x)) - >$< pairF word32HexFixed word32HexFixed - --- | Encode a 'Int8' using 2 nibbles (hexadecimal digits). -{-# INLINE int8HexFixed #-} -int8HexFixed :: FixedEncoding Int8 -int8HexFixed = fromIntegral >$< word8HexFixed - --- | Encode a 'Int16' using 4 nibbles. -{-# INLINE int16HexFixed #-} -int16HexFixed :: FixedEncoding Int16 -int16HexFixed = fromIntegral >$< word16HexFixed - --- | Encode a 'Int32' using 8 nibbles. -{-# INLINE int32HexFixed #-} -int32HexFixed :: FixedEncoding Int32 -int32HexFixed = fromIntegral >$< word32HexFixed - --- | Encode a 'Int64' using 16 nibbles. -{-# INLINE int64HexFixed #-} -int64HexFixed :: FixedEncoding Int64 -int64HexFixed = fromIntegral >$< word64HexFixed - --- | Encode an IEEE 'Float' using 8 nibbles. -{-# INLINE floatHexFixed #-} -floatHexFixed :: FixedEncoding Float -floatHexFixed = encodeFloatViaWord32F word32HexFixed - --- | Encode an IEEE 'Double' using 16 nibbles. -{-# INLINE doubleHexFixed #-} -doubleHexFixed :: FixedEncoding Double -doubleHexFixed = encodeDoubleViaWord64F word64HexFixed - - diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Binary.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Binary.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding/Binary.hs +++ /dev/null @@ -1,336 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns #-} --- | Copyright : (c) 2010-2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC --- -module Data.ByteString.Lazy.Builder.BasicEncoding.Binary ( - - -- ** Binary encodings - int8 - , word8 - - -- *** Big-endian - , int16BE - , int32BE - , int64BE - - , word16BE - , word32BE - , word64BE - - , floatBE - , doubleBE - - -- *** Little-endian - , int16LE - , int32LE - , int64LE - - , word16LE - , word32LE - , word64LE - - , floatLE - , doubleLE - - -- *** Non-portable, host-dependent - , intHost - , int16Host - , int32Host - , int64Host - - , wordHost - , word16Host - , word32Host - , word64Host - - , floatHost - , doubleHost - - ) where - -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Floating - -import Foreign - -#include "MachDeps.h" - ------------------------------------------------------------------------------- --- Binary encoding ------------------------------------------------------------------------------- - --- Word encodings ------------------ - --- | Encoding single unsigned bytes as-is. --- -{-# INLINE word8 #-} -word8 :: FixedEncoding Word8 -word8 = storableToF - --- --- We rely on the fromIntegral to do the right masking for us. --- The inlining here is critical, and can be worth 4x performance --- - --- | Encoding 'Word16's in big endian format. -{-# INLINE word16BE #-} -word16BE :: FixedEncoding Word16 -#ifdef WORD_BIGENDIAN -word16BE = word16Host -#else -word16BE = fixedEncoding 2 $ \w p -> do - poke p (fromIntegral (shiftr_w16 w 8) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) -#endif - --- | Encoding 'Word16's in little endian format. -{-# INLINE word16LE #-} -word16LE :: FixedEncoding Word16 -#ifdef WORD_BIGENDIAN -word16LE = fixedEncoding 2 $ \w p -> do - poke p (fromIntegral (w) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) -#else -word16LE = word16Host -#endif - --- | Encoding 'Word32's in big endian format. -{-# INLINE word32BE #-} -word32BE :: FixedEncoding Word32 -#ifdef WORD_BIGENDIAN -word32BE = word32Host -#else -word32BE = fixedEncoding 4 $ \w p -> do - poke p (fromIntegral (shiftr_w32 w 24) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (w) :: Word8) -#endif - --- | Encoding 'Word32's in little endian format. -{-# INLINE word32LE #-} -word32LE :: FixedEncoding Word32 -#ifdef WORD_BIGENDIAN -word32LE = fixedEncoding 4 $ \w p -> do - poke p (fromIntegral (w) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8) -#else -word32LE = word32Host -#endif - --- on a little endian machine: --- word32LE w32 = fixedEncoding 4 (\w p -> poke (castPtr p) w32) - --- | Encoding 'Word64's in big endian format. -{-# INLINE word64BE #-} -word64BE :: FixedEncoding Word64 -#ifdef WORD_BIGENDIAN -word64BE = word64Host -#else -#if WORD_SIZE_IN_BITS < 64 --- --- To avoid expensive 64 bit shifts on 32 bit machines, we cast to --- Word32, and write that --- -word64BE = - fixedEncoding 8 $ \w p -> do - let a = fromIntegral (shiftr_w64 w 32) :: Word32 - b = fromIntegral w :: Word32 - poke p (fromIntegral (shiftr_w32 a 24) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (a) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (b) :: Word8) -#else -word64BE = fixedEncoding 8 $ \w p -> do - poke p (fromIntegral (shiftr_w64 w 56) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (w) :: Word8) -#endif -#endif - --- | Encoding 'Word64's in little endian format. -{-# INLINE word64LE #-} -word64LE :: FixedEncoding Word64 -#ifdef WORD_BIGENDIAN -#if WORD_SIZE_IN_BITS < 64 -word64LE = - fixedEncoding 8 $ \w p -> do - let b = fromIntegral (shiftr_w64 w 32) :: Word32 - a = fromIntegral w :: Word32 - poke (p) (fromIntegral (a) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (b) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8) -#else -word64LE = fixedEncoding 8 $ \w p -> do - poke p (fromIntegral (w) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8) -#endif -#else -word64LE = word64Host -#endif - - --- | Encode a single native machine 'Word'. The 'Word's is encoded in host order, --- host endian form, for the machine you are on. On a 64 bit machine the 'Word' --- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way --- are not portable to different endian or word sized machines, without --- conversion. --- -{-# INLINE wordHost #-} -wordHost :: FixedEncoding Word -wordHost = storableToF - --- | Encoding 'Word16's in native host order and host endianness. -{-# INLINE word16Host #-} -word16Host :: FixedEncoding Word16 -word16Host = storableToF - --- | Encoding 'Word32's in native host order and host endianness. -{-# INLINE word32Host #-} -word32Host :: FixedEncoding Word32 -word32Host = storableToF - --- | Encoding 'Word64's in native host order and host endianness. -{-# INLINE word64Host #-} -word64Host :: FixedEncoding Word64 -word64Host = storableToF - - ------------------------------------------------------------------------------- --- Int encodings ------------------------------------------------------------------------------- --- --- We rely on 'fromIntegral' to do a loss-less conversion to the corresponding --- 'Word' type --- ------------------------------------------------------------------------------- - --- | Encoding single signed bytes as-is. --- -{-# INLINE int8 #-} -int8 :: FixedEncoding Int8 -int8 = fromIntegral >$< word8 - --- | Encoding 'Int16's in big endian format. -{-# INLINE int16BE #-} -int16BE :: FixedEncoding Int16 -int16BE = fromIntegral >$< word16BE - --- | Encoding 'Int16's in little endian format. -{-# INLINE int16LE #-} -int16LE :: FixedEncoding Int16 -int16LE = fromIntegral >$< word16LE - --- | Encoding 'Int32's in big endian format. -{-# INLINE int32BE #-} -int32BE :: FixedEncoding Int32 -int32BE = fromIntegral >$< word32BE - --- | Encoding 'Int32's in little endian format. -{-# INLINE int32LE #-} -int32LE :: FixedEncoding Int32 -int32LE = fromIntegral >$< word32LE - --- | Encoding 'Int64's in big endian format. -{-# INLINE int64BE #-} -int64BE :: FixedEncoding Int64 -int64BE = fromIntegral >$< word64BE - --- | Encoding 'Int64's in little endian format. -{-# INLINE int64LE #-} -int64LE :: FixedEncoding Int64 -int64LE = fromIntegral >$< word64LE - - --- TODO: Ensure that they are safe on architectures where an unaligned write is --- an error. - --- | Encode a single native machine 'Int'. The 'Int's is encoded in host order, --- host endian form, for the machine you are on. On a 64 bit machine the 'Int' --- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way --- are not portable to different endian or integer sized machines, without --- conversion. --- -{-# INLINE intHost #-} -intHost :: FixedEncoding Int -intHost = storableToF - --- | Encoding 'Int16's in native host order and host endianness. -{-# INLINE int16Host #-} -int16Host :: FixedEncoding Int16 -int16Host = storableToF - --- | Encoding 'Int32's in native host order and host endianness. -{-# INLINE int32Host #-} -int32Host :: FixedEncoding Int32 -int32Host = storableToF - --- | Encoding 'Int64's in native host order and host endianness. -{-# INLINE int64Host #-} -int64Host :: FixedEncoding Int64 -int64Host = storableToF - --- IEEE Floating Point Numbers ------------------------------- - --- | Encode a 'Float' in big endian format. -{-# INLINE floatBE #-} -floatBE :: FixedEncoding Float -floatBE = encodeFloatViaWord32F word32BE - --- | Encode a 'Float' in little endian format. -{-# INLINE floatLE #-} -floatLE :: FixedEncoding Float -floatLE = encodeFloatViaWord32F word32LE - --- | Encode a 'Double' in big endian format. -{-# INLINE doubleBE #-} -doubleBE :: FixedEncoding Double -doubleBE = encodeDoubleViaWord64F word64BE - --- | Encode a 'Double' in little endian format. -{-# INLINE doubleLE #-} -doubleLE :: FixedEncoding Double -doubleLE = encodeDoubleViaWord64F word64LE - - --- | Encode a 'Float' in native host order and host endianness. Values written --- this way are not portable to different endian machines, without conversion. --- -{-# INLINE floatHost #-} -floatHost :: FixedEncoding Float -floatHost = storableToF - --- | Encode a 'Double' in native host order and host endianness. -{-# INLINE doubleHost #-} -doubleHost :: FixedEncoding Double -doubleHost = storableToF - - diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Extras.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Extras.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding/Extras.hs +++ /dev/null @@ -1,890 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_HADDOCK hide #-} -{- | Copyright : (c) 2010-2011 Simon Meier -License : BSD3-style (see LICENSE) - -Maintainer : Simon Meier -Stability : experimental -Portability : GHC - -An /encoding/ is a conversion function of Haskell values to sequences of bytes. -A /fixed(-size) encoding/ is an encoding that always results in sequence of bytes - of a pre-determined, fixed length. -An example for a fixed encoding is the big-endian encoding of a 'Word64', - which always results in exactly 8 bytes. -A /bounded(-size) encoding/ is an encoding that always results in sequence - of bytes that is no larger than a pre-determined bound. -An example for a bounded encoding is the UTF-8 encoding of a 'Char', - which results always in less or equal to 4 bytes. -Note that every fixed encoding is also a bounded encoding. -We explicitly identify fixed encodings because they allow some optimizations - that are impossible with bounded encodings. -In the following, - we first motivate the use of bounded encodings - and then give examples of optimizations - that are only possible with fixed encodings. - -Typicall, encodings are implemented efficiently by allocating a buffer - (a mutable array of bytes) - and repeatedly executing the following two steps: - (1) writing to the buffer until it is full and - (2) handing over the filled part to the consumer of the encoded value. -Step (1) is where bounded encodings are used. -We must use a bounded encoding, - as we must check that there is enough free space - /before/ actually writing to the buffer. - -In term of expressivity, - it would be sufficient to construct all encodings - from the single fixed encoding that encodes a 'Word8' as-is. -However, - this is not sufficient in terms of efficiency. -It results in unnecessary buffer-full checks and - it complicates the program-flow for writing to the buffer, - as buffer-full checks are interleaved with analyzing the value to be - encoded (e.g., think about the program-flow for UTF-8 encoding). -This has a significant effect on overall encoding performance, - as encoding primitive Haskell values such as 'Word8's or 'Char's - lies at the heart of every encoding implementation. - -The 'BoundedEncoding's provided by this module remove this performance problem. -Intuitively, - they consist of a tuple of the bound on the maximal number of bytes written - and the actual implementation of the encoding as - a function that modifies a mutable buffer. -Hence when executing a 'BoundedEncoding', - the buffer-full check can be done once before the actual writing to the buffer. -The provided 'BoundedEncoding's also take care to implement the - actual writing to the buffer efficiently. -Moreover, combinators are provided to construct new bounded encodings - from the provided ones. - - - -The result of an encoding can be consumed efficiently, - if it is represented as a sequence of large enough - /chunks/ of consecutive memory (i.e., C @char@ arrays). -The precise meaning of /large enough/ is application dependent. -Typically, an average chunk size between 4kb and 32kb is suitable - for writing the result to disk or sending it over the network. -We desire large enough chunk sizes because each chunk boundary - incurs extra work that we must be able to amortize. - - -The need for fixed-size encodings arises when considering - the efficient implementation of encodings that require the encoding of a - value to be prefixed with the size of the resulting sequence of bytes. -An efficient implementation avoids unnecessary buffer -We can implement this efficiently as follows. -We first reserve the space for the encoding of the size. -Then, we encode the value. -Finally, we encode the size of the resulting sequence of bytes into - the reserved space. -For this to work - -This works only if the encoding resulting size fits - -by first, reserving the space for the encoding - of the size, then performing the - -For efficiency, - we want to avoid unnecessary copying. - - -For example, the HTTP/1.0 requires the size of the body to be given in - the Content-Length field. - -chunked-transfer encoding requires each chunk to - be prefixed with the hexadecimal encoding of the chunk size. - - --} - -{- --- --- --- A /bounded encoding/ is an encoding that never results in a sequence --- longer than some fixed number of bytes. This number of bytes must be --- independent of the value being encoded. Typical examples of bounded --- encodings are the big-endian encoding of a 'Word64', which results always --- in exactly 8 bytes, or the UTF-8 encoding of a 'Char', which results always --- in less or equal to 4 bytes. --- --- Typically, encodings are implemented efficiently by allocating a buffer (an --- array of bytes) and repeatedly executing the following two steps: (1) --- writing to the buffer until it is full and (2) handing over the filled part --- to the consumer of the encoded value. Step (1) is where bounded encodings --- are used. We must use a bounded encoding, as we must check that there is --- enough free space /before/ actually writing to the buffer. --- --- In term of expressivity, it would be sufficient to construct all encodings --- from the single bounded encoding that encodes a 'Word8' as-is. However, --- this is not sufficient in terms of efficiency. It results in unnecessary --- buffer-full checks and it complicates the program-flow for writing to the --- buffer, as buffer-full checks are interleaved with analyzing the value to be --- encoded (e.g., think about the program-flow for UTF-8 encoding). This has a --- significant effect on overall encoding performance, as encoding primitive --- Haskell values such as 'Word8's or 'Char's lies at the heart of every --- encoding implementation. --- --- The bounded 'Encoding's provided by this module remove this performance --- problem. Intuitively, they consist of a tuple of the bound on the maximal --- number of bytes written and the actual implementation of the encoding as a --- function that modifies a mutable buffer. Hence when executing a bounded --- 'Encoding', the buffer-full check can be done once before the actual writing --- to the buffer. The provided 'Encoding's also take care to implement the --- actual writing to the buffer efficiently. Moreover, combinators are --- provided to construct new bounded encodings from the provided ones. --- --- A typical example for using the combinators is a bounded 'Encoding' that --- combines escaping the ' and \\ characters with UTF-8 encoding. More --- precisely, the escaping to be done is the one implemented by the following --- @escape@ function. --- --- > escape :: Char -> [Char] --- > escape '\'' = "\\'" --- > escape '\\' = "\\\\" --- > escape c = [c] --- --- The bounded 'Encoding' that combines this escaping with UTF-8 encoding is --- the following. --- --- > import Data.ByteString.Lazy.Builder.BasicEncoding.Utf8 (char) --- > --- > {-# INLINE escapeChar #-} --- > escapeUtf8 :: BoundedEncoding Char --- > escapeUtf8 = --- > encodeIf ('\'' ==) (char <#> char #. const ('\\','\'')) $ --- > encodeIf ('\\' ==) (char <#> char #. const ('\\','\\')) $ --- > char --- --- The definition of 'escapeUtf8' is more complicated than 'escape', because --- the combinators ('encodeIf', 'encodePair', '#.', and 'char') used in --- 'escapeChar' compute both the bound on the maximal number of bytes written --- (8 for 'escapeUtf8') as well as the low-level buffer manipulation required --- to implement the encoding. Bounded 'Encoding's should always be inlined. --- Otherwise, the compiler cannot compute the bound on the maximal number of --- bytes written at compile-time. Without inlinining, it would also fail to --- optimize the constant encoding of the escape characters in the above --- example. Functions that execute bounded 'Encoding's also perform --- suboptimally, if the definition of the bounded 'Encoding' is not inlined. --- Therefore we add an 'INLINE' pragma to 'escapeUtf8'. --- --- Currently, the only library that executes bounded 'Encoding's is the --- 'bytestring' library (). It --- uses bounded 'Encoding's to implement most of its lazy bytestring builders. --- Executing a bounded encoding should be done using the corresponding --- functions in the lazy bytestring builder 'Extras' module. --- --- TODO: Merge with explanation/example below --- --- Bounded 'E.Encoding's abstract encodings of Haskell values that can be implemented by --- writing a bounded-size sequence of bytes directly to memory. They are --- lifted to conversions from Haskell values to 'Builder's by wrapping them --- with a bound-check. The compiler can implement this bound-check very --- efficiently (i.e, a single comparison of the difference of two pointers to a --- constant), because the bound of a 'E.Encoding' is always independent of the --- value being encoded and, in most cases, a literal constant. --- --- 'E.Encoding's are the primary means for defining conversion functions from --- primitive Haskell values to 'Builder's. Most 'Builder' constructors --- provided by this library are implemented that way. --- 'E.Encoding's are also used to construct conversions that exploit the internal --- representation of data-structures. --- --- For example, 'encodeByteStringWith' works directly on the underlying byte --- array and uses some tricks to reduce the number of variables in its inner --- loop. Its efficiency is exploited for implementing the @filter@ and @map@ --- functions in "Data.ByteString.Lazy" as --- --- > import qualified Codec.Bounded.Encoding as E --- > --- > filter :: (Word8 -> Bool) -> ByteString -> ByteString --- > filter p = toLazyByteString . encodeLazyByteStringWithB write --- > where --- > write = E.encodeIf p E.word8 E.emptyEncoding --- > --- > map :: (Word8 -> Word8) -> ByteString -> ByteString --- > map f = toLazyByteString . encodeLazyByteStringWithB (E.word8 E.#. f) --- --- Compared to earlier versions of @filter@ and @map@ on lazy 'L.ByteString's, --- these versions use a more efficient inner loop and have the additional --- advantage that they always result in well-chunked 'L.ByteString's; i.e, they --- also perform automatic defragmentation. --- --- We can also use 'E.Encoding's to improve the efficiency of the following --- 'renderString' function from our UTF-8 CSV table encoding example in --- "Data.ByteString.Lazy.Builder". --- --- > renderString :: String -> Builder --- > renderString cs = charUtf8 '"' <> foldMap escape cs <> charUtf8 '"' --- > where --- > escape '\\' = charUtf8 '\\' <> charUtf8 '\\' --- > escape '\"' = charUtf8 '\\' <> charUtf8 '\"' --- > escape c = charUtf8 c --- --- The idea is to save on 'mappend's by implementing a 'E.Encoding' that escapes --- characters and using 'encodeListWith', which implements writing a list of --- values with a tighter inner loop and no 'mappend'. --- --- > import Data.ByteString.Lazy.Builder.Extras -- assume these three --- > import Codec.Bounded.Encoding -- imports are present --- > ( BoundedEncoding, encodeIf, (<#>), (#.) ) --- > import Data.ByteString.Lazy.Builder.BasicEncoding.Utf8 (char) --- > --- > renderString :: String -> Builder --- > renderString cs = --- > charUtf8 '"' <> encodeListWithB escapedUtf8 cs <> charUtf8 '"' --- > where --- > escapedUtf8 :: BoundedEncoding Char --- > escapedUtf8 = --- > encodeIf (== '\\') (char <#> char #. const ('\\', '\\')) $ --- > encodeIf (== '\"') (char <#> char #. const ('\\', '\"')) $ --- > char --- --- This 'Builder' considers a buffer with less than 8 free bytes as full. As --- all functions are inlined, the compiler is able to optimize the constant --- 'E.Encoding's as two sequential 'poke's. Compared to the first implementation of --- 'renderString' this implementation is 1.7x faster. --- --} -{- -Internally, 'Builder's are buffer-fill operations that are -given a continuation buffer-fill operation and a buffer-range to be filled. -A 'Builder' first checks if the buffer-range is large enough. If that's -the case, the 'Builder' writes the sequences of bytes to the buffer and -calls its continuation. Otherwise, it returns a signal that it requires a -new buffer together with a continuation to be called on this new buffer. -Ignoring the rare case of a full buffer-range, the execution cost of a -'Builder' consists of three parts: - - 1. The time taken to read the parameters; i.e., the buffer-fill - operation to call after the 'Builder' is done and the buffer-range to - fill. - - 2. The time taken to check for the size of the buffer-range. - - 3. The time taken for the actual encoding. - -We can reduce cost (1) by ensuring that fewer buffer-fill function calls are -required. We can reduce cost (2) by fusing buffer-size checks of sequential -writes. For example, when escaping a 'String' using 'renderString', it would -be sufficient to check before encoding a character that at least 8 bytes are -free. We can reduce cost (3) by implementing better primitive 'Builder's. -For example, 'renderCell' builds an intermediate list containing the decimal -representation of an 'Int'. Implementing a direct decimal encoding of 'Int's -to memory would be more efficient, as it requires fewer buffer-size checks -and less allocation. It is also a planned extension of this library. - -The first two cost reductions are supported for user code through functions -in "Data.ByteString.Lazy.Builder.Extras". There, we continue the above example -and drop the generation time to 0.8ms by implementing 'renderString' more -cleverly. The third reduction requires meddling with the internals of -'Builder's and is not recomended in code outside of this library. However, -patches to this library are very welcome. --} -module Data.ByteString.Lazy.Builder.BasicEncoding.Extras ( - - -- * Base-128, variable-length binary encodings - {- | -There are many options for implementing a base-128 (i.e, 7-bit), -variable-length encoding. The encoding implemented here is the one used by -Google's protocol buffer library -. This -encoding can be implemented efficiently and provides the desired property that -small positive integers result in short sequences of bytes. It is intended to -be used for the new default binary serialization format of the differently -sized 'Word' types. It works as follows. - -The most-significant bit (MSB) of each output byte indicates whether -there is a following byte (MSB set to 1) or it is the last byte (MSB set to 0). -The remaining 7-bits are used to encode the input starting with the least -significant 7-bit group of the input (i.e., a little-endian ordering of the -7-bit groups is used). - -For example, the value @1 :: Int@ is encoded as @[0x01]@. The value -@128 :: Int@, whose binary representation is @1000 0000@, is encoded as -@[0x80, 0x01]@; i.e., the first byte has its MSB set and the least significant -7-bit group is @000 0000@, the second byte has its MSB not set (it is the last -byte) and its 7-bit group is @000 0001@. --} - word8Var - , word16Var - , word32Var - , word64Var - , wordVar - -{- | -The following encodings work by casting the signed integer to the equally sized -unsigned integer. This works well for positive integers, but for negative -integers it always results in the longest possible sequence of bytes, -as their MSB is (by definition) always set. --} - - , int8Var - , int16Var - , int32Var - , int64Var - , intVar - -{- | -Positive and negative integers of small magnitude can be encoded compactly - using the so-called ZigZag encoding - (). -The /ZigZag encoding/ uses - even numbers to encode the postive integers and - odd numbers to encode the negative integers. -For example, - @0@ is encoded as @0@, @-1@ as @1@, @1@ as @2@, @-2@ as @3@, @2@ as @4@, and - so on. -Its efficient implementation uses some bit-level magic. -For example - -@ -zigZag32 :: 'Int32' -> 'Word32' -zigZag32 n = fromIntegral ((n \`shiftL\` 1) \`xor\` (n \`shiftR\` 31)) -@ - -Note that the 'shiftR' is an arithmetic shift that performs sign extension. -The ZigZag encoding essentially swaps the LSB with the MSB and additionally -inverts all bits if the MSB is set. - -The following encodings implement the combintion of ZigZag encoding - together with the above base-128, variable length encodings. -They are intended to become the the new default binary serialization format of - the differently sized 'Int' types. --} - , int8VarSigned - , int16VarSigned - , int32VarSigned - , int64VarSigned - , intVarSigned - - - -- * Chunked / size-prefixed encodings -{- | -Some encodings like ASN.1 BER -or Google's protocol buffers require -encoded data to be prefixed with its length. The simple method to achieve this -is to encode the data first into a separate buffer, compute the length of the -encoded data, write it to the current output buffer, and append the separate -buffers. The drawback of this method is that it requires a ... --} - , size - , sizeBound - -- , withSizeFB - -- , withSizeBB - , encodeWithSize - - , encodeChunked - - , wordVarFixedBound - , wordHexFixedBound - , wordDecFixedBound - - , word64VarFixedBound - , word64HexFixedBound - , word64DecFixedBound - - ) where - -import Data.ByteString.Lazy.Builder.Internal -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Base16 (lowerTable, encode4_as_8) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy.Internal as L - -import Data.Monoid -import Data.List (unfoldr) -- HADDOCK ONLY -import Data.Char (chr, ord) -import Control.Monad ((<=<), unless) - -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal hiding (size, sizeBound) -import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Internal as I (size, sizeBound) -import Data.ByteString.Lazy.Builder.BasicEncoding.Binary -import Data.ByteString.Lazy.Builder.BasicEncoding.ASCII -import Data.ByteString.Lazy.Builder.BasicEncoding - -import Foreign - ------------------------------------------------------------------------------- --- Adapting 'size' for the public interface. ------------------------------------------------------------------------------- - --- | The size of the sequence of bytes generated by this 'FixedEncoding'. -size :: FixedEncoding a -> Word -size = fromIntegral . I.size - --- | The bound on the size of the sequence of bytes generated by this --- 'BoundedEncoding'. -sizeBound :: BoundedEncoding a -> Word -sizeBound = fromIntegral . I.sizeBound - - ------------------------------------------------------------------------------- --- Base-128 Variable-Length Encodings ------------------------------------------------------------------------------- - -{-# INLINE encodeBase128 #-} -encodeBase128 - :: forall a b. (Integral a, Bits a, Storable b, Integral b, Num b) - => (a -> Int -> a) -> BoundedEncoding b -encodeBase128 shiftr = - -- We add 6 because we require the result of (`div` 7) to be rounded up. - boundedEncoding ((8 * sizeOf (undefined :: b) + 6) `div` 7) (io . fromIntegral) - where - io !x !op - | x' == 0 = do poke8 (x .&. 0x7f) - return $! op `plusPtr` 1 - | otherwise = do poke8 ((x .&. 0x7f) .|. 0x80) - io x' (op `plusPtr` 1) - where - x' = x `shiftr` 7 - poke8 = poke op . fromIntegral - --- | Base-128, variable length encoding of a 'Word8'. -{-# INLINE word8Var #-} -word8Var :: BoundedEncoding Word8 -word8Var = encodeBase128 shiftr_w - --- | Base-128, variable length encoding of a 'Word16'. -{-# INLINE word16Var #-} -word16Var :: BoundedEncoding Word16 -word16Var = encodeBase128 shiftr_w - --- | Base-128, variable length encoding of a 'Word32'. -{-# INLINE word32Var #-} -word32Var :: BoundedEncoding Word32 -word32Var = encodeBase128 shiftr_w32 - --- | Base-128, variable length encoding of a 'Word64'. -{-# INLINE word64Var #-} -word64Var :: BoundedEncoding Word64 -word64Var = encodeBase128 shiftr_w64 - --- | Base-128, variable length encoding of a 'Word'. -{-# INLINE wordVar #-} -wordVar :: BoundedEncoding Word -wordVar = encodeBase128 shiftr_w - - --- | Base-128, variable length encoding of an 'Int8'. --- Use 'int8VarSigned' for encoding negative numbers. -{-# INLINE int8Var #-} -int8Var :: BoundedEncoding Int8 -int8Var = fromIntegral >$< word8Var - --- | Base-128, variable length encoding of an 'Int16'. --- Use 'int16VarSigned' for encoding negative numbers. -{-# INLINE int16Var #-} -int16Var :: BoundedEncoding Int16 -int16Var = fromIntegral >$< word16Var - --- | Base-128, variable length encoding of an 'Int32'. --- Use 'int32VarSigned' for encoding negative numbers. -{-# INLINE int32Var #-} -int32Var :: BoundedEncoding Int32 -int32Var = fromIntegral >$< word32Var - --- | Base-128, variable length encoding of an 'Int64'. --- Use 'int64VarSigned' for encoding negative numbers. -{-# INLINE int64Var #-} -int64Var :: BoundedEncoding Int64 -int64Var = fromIntegral >$< word64Var - --- | Base-128, variable length encoding of an 'Int'. --- Use 'intVarSigned' for encoding negative numbers. -{-# INLINE intVar #-} -intVar :: BoundedEncoding Int -intVar = fromIntegral >$< wordVar - -{-# INLINE zigZag #-} -zigZag :: (Storable a, Bits a) => a -> a -zigZag x = (x `shiftL` 1) `xor` (x `shiftR` (8 * sizeOf x - 1)) - --- | Base-128, variable length, ZigZag encoding of an 'Int'. -{-# INLINE int8VarSigned #-} -int8VarSigned :: BoundedEncoding Int8 -int8VarSigned = zigZag >$< int8Var - --- | Base-128, variable length, ZigZag encoding of an 'Int16'. -{-# INLINE int16VarSigned #-} -int16VarSigned :: BoundedEncoding Int16 -int16VarSigned = zigZag >$< int16Var - --- | Base-128, variable length, ZigZag encoding of an 'Int32'. -{-# INLINE int32VarSigned #-} -int32VarSigned :: BoundedEncoding Int32 -int32VarSigned = zigZag >$< int32Var - --- | Base-128, variable length, ZigZag encoding of an 'Int64'. -{-# INLINE int64VarSigned #-} -int64VarSigned :: BoundedEncoding Int64 -int64VarSigned = zigZag >$< int64Var - --- | Base-128, variable length, ZigZag encoding of an 'Int'. -{-# INLINE intVarSigned #-} -intVarSigned :: BoundedEncoding Int -intVarSigned = zigZag >$< intVar - - - ------------------------------------------------------------------------------- --- Chunked Encoding Transformer ------------------------------------------------------------------------------- - --- | /Heavy inlining./ -{-# INLINE encodeChunked #-} -encodeChunked - :: Word -- ^ Minimal free-size - -> (Word64 -> FixedEncoding Word64) - -- ^ Given a sizeBound on the maximal encodable size this function must return - -- a fixed-size encoding for encoding all smaller size. - -> (BoundedEncoding Word64) - -- ^ An encoding for terminating a chunk of the given size. - -> Builder - -- ^ Inner Builder to transform - -> Builder - -- ^ 'Put' with chunked encoding. -encodeChunked minFree mkBeforeFE afterBE = - fromPut . putChunked minFree mkBeforeFE afterBE . putBuilder - --- | /Heavy inlining./ -{-# INLINE putChunked #-} -putChunked - :: Word -- ^ Minimal free-size - -> (Word64 -> FixedEncoding Word64) - -- ^ Given a sizeBound on the maximal encodable size this function must return - -- a fixed-size encoding for encoding all smaller size. - -> (BoundedEncoding Word64) - -- ^ Encoding a directly inserted chunk. - -> Put a - -- ^ Inner Put to transform - -> Put a - -- ^ 'Put' with chunked encoding. -putChunked minFree0 mkBeforeFE afterBE p = - put encodingStep - where - minFree, reservedAfter, maxReserved, minBufferSize :: Int - minFree = fromIntegral $ max 1 minFree0 -- sanitize and convert to Int - - -- reserved space must be computed for maximum buffer size to cover for all - -- sizes of the actually returned buffer. - reservedAfter = I.sizeBound afterBE - maxReserved = I.size (mkBeforeFE maxBound) + reservedAfter - minBufferSize = minFree + maxReserved - - encodingStep k = - fill (runPut p) - where - fill innerStep !(BufferRange op ope) - | outRemaining < minBufferSize = - return $! bufferFull minBufferSize op (fill innerStep) - | otherwise = do - fillWithBuildStep innerStep doneH fullH insertChunksH brInner - where - outRemaining = ope `minusPtr` op - beforeFE = mkBeforeFE $ fromIntegral outRemaining - reservedBefore = I.size beforeFE - - opInner = op `plusPtr` reservedBefore - opeInner = ope `plusPtr` (-reservedAfter) - brInner = BufferRange opInner opeInner - - wrapChunk :: Ptr Word8 -> IO (Ptr Word8) - wrapChunk !opInner' - | innerSize == 0 = return op -- no data written => no chunk to wrap - | otherwise = do - runF beforeFE innerSize op - runB afterBE innerSize opInner' - where - innerSize = fromIntegral $ opInner' `minusPtr` opInner - - doneH opInner' x = do - op' <- wrapChunk opInner' - let !br' = BufferRange op' ope - k x br' - - fullH opInner' minSize nextInnerStep = do - op' <- wrapChunk opInner' - return $! bufferFull - (max minBufferSize (minSize + maxReserved)) - op' - (fill nextInnerStep) - - insertChunksH opInner' n lbsC nextInnerStep - | n == 0 = do -- flush - op' <- wrapChunk opInner' - return $! insertChunks op' 0 id (fill nextInnerStep) - - | otherwise = do -- insert non-empty bytestring - op' <- wrapChunk opInner' - let !br' = BufferRange op' ope - runBuilderWith chunkB (fill nextInnerStep) br' - where - nU = fromIntegral n - chunkB = - encodeWithF (mkBeforeFE nU) nU `mappend` - lazyByteStringC n lbsC `mappend` - encodeWithB afterBE nU - - --- | /Heavy inlining./ Prefix a 'Builder' with the size of the --- sequence of bytes that it denotes. --- --- This function is optimized for streaming use. It tries to prefix the size --- without copying the output. This is achieved by reserving space for the --- maximum size to be encoded. This succeeds if the output is smaller than --- the current free buffer size, which is guaranteed to be at least @8kb@. --- --- If the output does not fit into the current free buffer size, --- the method falls back to encoding the data to a separate lazy bytestring, --- computing the size, and encoding the size before inserting the chunks of --- the separate lazy bytestring. -{-# INLINE encodeWithSize #-} -encodeWithSize - :: - Word - -- ^ Inner buffer-size. - -> (Word64 -> FixedEncoding Word64) - -- ^ Given a bound on the maximal size to encode, this function must return - -- a fixed-size encoding for all smaller sizes. - -> Builder - -- ^ 'Put' to prefix with the length of its sequence of bytes. - -> Builder -encodeWithSize innerBufSize mkSizeFE = - fromPut . putWithSize innerBufSize mkSizeFE . putBuilder - --- | Prefix a 'Put' with the size of its written data. -{-# INLINE putWithSize #-} -putWithSize - :: forall a. - Word - -- ^ Buffer-size for inner driver. - -> (Word64 -> FixedEncoding Word64) - -- ^ Encoding the size for the fallback case. - -> Put a - -- ^ 'Put' to prefix with the length of its sequence of bytes. - -> Put a -putWithSize innerBufSize mkSizeFE innerP = - put $ encodingStep - where - -- | The minimal free size is such that we can encode any size. - minFree = I.size $ mkSizeFE maxBound - - encodingStep :: (forall r. (a -> BuildStep r) -> BuildStep r) - encodingStep k = - fill (runPut innerP) - where - fill :: BuildStep a -> BufferRange -> IO (BuildSignal r) - fill innerStep !(BufferRange op ope) - | outRemaining < minFree = - return $! bufferFull minFree op (fill innerStep) - | otherwise = do - fillWithBuildStep innerStep doneH fullH insertChunksH brInner - where - outRemaining = ope `minusPtr` op - sizeFE = mkSizeFE $ fromIntegral outRemaining - reservedBefore = I.size sizeFE - reservedAfter = minFree - reservedBefore - - -- leave enough free space such that all sizes can be encodded. - startInner = op `plusPtr` reservedBefore - opeInner = ope `plusPtr` (negate reservedAfter) - brInner = BufferRange startInner opeInner - - fastPrefixSize :: Ptr Word8 -> IO (Ptr Word8) - fastPrefixSize !opInner' - | innerSize == 0 = do runB (toB $ mkSizeFE 0) 0 op - | otherwise = do runF (sizeFE) innerSize op - return opInner' - where - innerSize = fromIntegral $ opInner' `minusPtr` startInner - - slowPrefixSize :: Ptr Word8 -> Builder -> BuildStep a -> IO (BuildSignal r) - slowPrefixSize opInner' bInner nextStep = do - (x, chunks, payLenChunks) <- toLBS $ runBuilderWith bInner nextStep - - let -- length of payload data in current buffer - payLenCur = opInner' `minusPtr` startInner - -- length of whole payload - payLen = fromIntegral payLenCur + fromIntegral payLenChunks - -- encoder for payload length - sizeFE' = mkSizeFE payLen - -- start of payload in current buffer with the payload - -- length encoded before - startInner' = op `plusPtr` I.size sizeFE' - - -- move data in current buffer out of the way, if required - unless (startInner == startInner') $ - moveBytes startInner' startInner payLenCur - -- encode payload length at start of the buffer - runF sizeFE' payLen op - -- TODO: If we were to change the CIOS definition such that it also - -- returns the last buffer for writing, we could also fill the - -- last buffer with 'k' and return the signal, once it is - -- filled, therefore avoiding unfilled space. - return $ insertChunks (startInner' `plusPtr` payLenCur) - payLenChunks - chunks - (k x) - where - toLBS = runCIOSWithLength <=< - buildStepToCIOSUntrimmedWith (fromIntegral innerBufSize) - - doneH :: Ptr Word8 -> a -> IO (BuildSignal r) - doneH opInner' x = do - op' <- fastPrefixSize opInner' - let !br' = BufferRange op' ope - k x br' - - fullH :: Ptr Word8 -> Int -> BuildStep a -> IO (BuildSignal r) - fullH opInner' minSize nextInnerStep = - slowPrefixSize opInner' (ensureFree minSize) nextInnerStep - - insertChunksH :: Ptr Word8 -> Int64 -> LazyByteStringC - -> BuildStep a -> IO (BuildSignal r) - insertChunksH opInner' n lbsC nextInnerStep = - slowPrefixSize opInner' (lazyByteStringC n lbsC) nextInnerStep - - --- | Run a 'ChunkIOStream' and gather its results and their length. -runCIOSWithLength :: ChunkIOStream a -> IO (a, LazyByteStringC, Int64) -runCIOSWithLength = - go 0 id - where - go !l lbsC (Finished x) = return (x, lbsC, l) - go !l lbsC (YieldC n lbsC' io) = io >>= go (l + n) (lbsC . lbsC') - go !l lbsC (Yield1 bs io) = - io >>= go (l + fromIntegral (S.length bs)) (lbsC . L.Chunk bs) - --- | Run a 'BuildStep' using the untrimmed strategy. -buildStepToCIOSUntrimmedWith :: Int -> BuildStep a -> IO (ChunkIOStream a) -buildStepToCIOSUntrimmedWith bufSize = - buildStepToCIOS (untrimmedStrategy bufSize bufSize) - (return . Finished) - - ----------------------------------------------------------------------- --- Padded versions of encodings for streamed prefixing of output sizes ----------------------------------------------------------------------- - -{-# INLINE appsUntilZero #-} -appsUntilZero :: (Eq a, Num a) => (a -> a) -> a -> Int -appsUntilZero f x0 = - count 0 x0 - where - count !n 0 = n - count !n x = count (succ n) (f x) - - -{-# INLINE genericVarFixedBound #-} -genericVarFixedBound :: (Eq b, Show b, Bits b, Num a, Integral b) - => (b -> a -> b) -> b -> FixedEncoding b -genericVarFixedBound shiftRight bound = - fixedEncoding n0 io - where - n0 = max 1 $ appsUntilZero (`shiftRight` 7) bound - - io !x0 !op - | x0 > bound = error err - | otherwise = loop 0 x0 - where - err = "genericVarFixedBound: value " ++ show x0 ++ " > bound " ++ show bound - loop !n !x - | n0 <= n + 1 = do poke8 (x .&. 0x7f) - | otherwise = do poke8 ((x .&. 0x7f) .|. 0x80) - loop (n + 1) (x `shiftRight` 7) - where - poke8 = pokeElemOff op n . fromIntegral - -{-# INLINE wordVarFixedBound #-} -wordVarFixedBound :: Word -> FixedEncoding Word -wordVarFixedBound = genericVarFixedBound shiftr_w - -{-# INLINE word64VarFixedBound #-} -word64VarFixedBound :: Word64 -> FixedEncoding Word64 -word64VarFixedBound = genericVarFixedBound shiftr_w64 - - --- Somehow this function doesn't really make sense, as the bound must be --- greater when interpreted as an unsigned integer. These conversions and --- decisions should be left to the user. --- ---{-# INLINE intVarFixed #-} ---intVarFixed :: Size -> FixedEncoding Size ---intVarFixed bound = fromIntegral >$< wordVarFixed (fromIntegral bound) - -{-# INLINE genHexFixedBound #-} -genHexFixedBound :: (Num a, Bits a, Integral a) - => (a -> Int -> a) -> Char -> a -> FixedEncoding a -genHexFixedBound shiftr padding0 bound = - fixedEncoding n0 io - where - n0 = max 1 $ appsUntilZero (`shiftr` 4) bound - - padding = fromIntegral (ord padding0) :: Word8 - - io !x0 !op0 = - loop (op0 `plusPtr` n0) x0 - where - loop !op !x = do - let !op' = op `plusPtr` (-1) - poke op' =<< encode4_as_8 lowerTable (fromIntegral $ x .&. 0xf) - let !x' = x `shiftr` 4 - unless (op' <= op0) $ - if x' == 0 - then pad (op' `plusPtr` (-1)) - else loop op' x' - - pad !op - | op < op0 = return () - | otherwise = poke op padding >> pad (op `plusPtr` (-1)) - - -{-# INLINE wordHexFixedBound #-} -wordHexFixedBound :: Char -> Word -> FixedEncoding Word -wordHexFixedBound = genHexFixedBound shiftr_w - -{-# INLINE word64HexFixedBound #-} -word64HexFixedBound :: Char -> Word64 -> FixedEncoding Word64 -word64HexFixedBound = genHexFixedBound shiftr_w64 - --- | Note: Works only for positive numbers. -{-# INLINE genDecFixedBound #-} -genDecFixedBound :: (Num a, Bits a, Integral a) - => Char -> a -> FixedEncoding a -genDecFixedBound padding0 bound = - fixedEncoding n0 io - where - n0 = max 1 $ appsUntilZero (`div` 10) bound - - padding = fromIntegral (ord padding0) :: Word8 - - io !x0 !op0 = - loop (op0 `plusPtr` n0) x0 - where - loop !op !x = do - let !op' = op `plusPtr` (-1) - !x' = x `div` 10 - poke op' ((fromIntegral $ (x - x' * 10) + 48) :: Word8) - unless (op' <= op0) $ - if x' == 0 - then pad (op' `plusPtr` (-1)) - else loop op' x' - - pad !op - | op < op0 = return () - | otherwise = poke op padding >> pad (op `plusPtr` (-1)) - -{-# INLINE wordDecFixedBound #-} -wordDecFixedBound :: Char -> Word -> FixedEncoding Word -wordDecFixedBound = genDecFixedBound - -{-# INLINE word64DecFixedBound #-} -word64DecFixedBound :: Char -> Word64 -> FixedEncoding Word64 -word64DecFixedBound = genDecFixedBound - diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal.hs +++ /dev/null @@ -1,353 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns #-} -{-# OPTIONS_HADDOCK hide #-} --- | --- Copyright : 2010-2011 Simon Meier, 2010 Jasper van der Jeugt --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : GHC --- --- This module is internal. It is only intended to be used by the 'bytestring' --- and the 'text' library. Please contact the maintainer, if you need to use --- this module in your library. We are glad to accept patches for further --- standard encodings of standard Haskell values. --- --- If you need to write your own primitive encoding, then be aware that you are --- writing code with /all saftey belts off/; i.e., --- *this is the code that might make your application vulnerable to buffer-overflow attacks!* --- The "Codec.Bounded.Encoding.Internal.Test" module provides you with --- utilities for testing your encodings thoroughly. --- -module Data.ByteString.Lazy.Builder.BasicEncoding.Internal ( - -- * Fixed-size Encodings - Size - , FixedEncoding - , fixedEncoding - , size - , runF - - , emptyF - , contramapF - , pairF - -- , liftIOF - - , storableToF - - -- * Bounded-size Encodings - , BoundedEncoding - , boundedEncoding - , sizeBound - , runB - - , emptyB - , contramapB - , pairB - , eitherB - , ifB - - -- , liftIOB - - , toB - , fromF - - -- , withSizeFB - -- , withSizeBB - - -- * Shared operators - , (>$<) - , (>*<) - - ) where - -import Foreign -import Prelude hiding (maxBound) - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 611 --- ghc-6.10 and older do not support {-# INLINE CONLIKE #-} -#define CONLIKE -#endif - ------------------------------------------------------------------------------- --- Supporting infrastructure ------------------------------------------------------------------------------- - --- | Contravariant functors as in the 'contravariant' package. -class Contravariant f where - contramap :: (b -> a) -> f a -> f b - -infixl 4 >$< - --- | An overloaded infix operator for 'contramapF' and 'contramapB'. --- --- We can use it for example to prepend and/or append fixed values to an --- encoding. --- --- >showEncoding ((\x -> ('\'', (x, '\''))) >$< fixed3) 'x' = "'x'" --- > where --- > fixed3 = char7 >*< char7 >*< char7 --- --- Note that the rather verbose syntax for composition stems from the --- requirement to be able to compute the 'size's and 'sizeBound's at --- compile time. --- -(>$<) :: Contravariant f => (b -> a) -> f a -> f b -(>$<) = contramap - - -instance Contravariant FixedEncoding where - contramap = contramapF - -instance Contravariant BoundedEncoding where - contramap = contramapB - - --- | Type-constructors supporting lifting of type-products. -class Monoidal f where - pair :: f a -> f b -> f (a, b) - -instance Monoidal FixedEncoding where - pair = pairF - -instance Monoidal BoundedEncoding where - pair = pairB - -infixr 5 >*< - --- | An overloaded infix operator for 'pairF' and 'pairB'. --- For example, --- --- >showF (char7 >*< char7) ('x','y') = "xy" --- --- We can combine multiple encodings using '>*<' multiple times. --- --- >showEncoding (char7 >*< char7 >*< char7) ('x',('y','z')) = "xyz" --- -(>*<) :: Monoidal f => f a -> f b -> f (a, b) -(>*<) = pair - - --- | The type used for sizes and sizeBounds of sizes. -type Size = Int - - ------------------------------------------------------------------------------- --- Fixed-size Encodings ------------------------------------------------------------------------------- - --- | An encoding that always results in a sequence of bytes of a --- pre-determined, fixed size. -data FixedEncoding a = FE {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO ()) - -fixedEncoding :: Int -> (a -> Ptr Word8 -> IO ()) -> FixedEncoding a -fixedEncoding = FE - --- | The size of the sequences of bytes generated by this 'FixedEncoding'. -{-# INLINE CONLIKE size #-} -size :: FixedEncoding a -> Int -size (FE l _) = l - -{-# INLINE CONLIKE runF #-} -runF :: FixedEncoding a -> a -> Ptr Word8 -> IO () -runF (FE _ io) = io - --- | The 'FixedEncoding' that always results in the zero-length sequence. -{-# INLINE CONLIKE emptyF #-} -emptyF :: FixedEncoding a -emptyF = FE 0 (\_ _ -> return ()) - --- | Encode a pair by encoding its first component and then its second component. -{-# INLINE CONLIKE pairF #-} -pairF :: FixedEncoding a -> FixedEncoding b -> FixedEncoding (a, b) -pairF (FE l1 io1) (FE l2 io2) = - FE (l1 + l2) (\(x1,x2) op -> io1 x1 op >> io2 x2 (op `plusPtr` l1)) - --- | Change an encoding such that it first applies a function to the value --- to be encoded. --- --- Note that encodings are 'Contrafunctors' --- . Hence, the following --- laws hold. --- --- >contramapF id = id --- >contramapF f . contramapF g = contramapF (g . f) -{-# INLINE CONLIKE contramapF #-} -contramapF :: (b -> a) -> FixedEncoding a -> FixedEncoding b -contramapF f (FE l io) = FE l (\x op -> io (f x) op) - --- | Convert a 'FixedEncoding' to a 'BoundedEncoding'. -{-# INLINE CONLIKE toB #-} -toB :: FixedEncoding a -> BoundedEncoding a -toB (FE l io) = BE l (\x op -> io x op >> (return $! op `plusPtr` l)) - --- | Convert a 'FixedEncoding' to a 'BoundedEncoding'. -{-# INLINE CONLIKE fromF #-} -fromF :: FixedEncoding a -> BoundedEncoding a -fromF = toB - -{-# INLINE CONLIKE storableToF #-} -storableToF :: forall a. Storable a => FixedEncoding a -storableToF = FE (sizeOf (undefined :: a)) (\x op -> poke (castPtr op) x) - -{- -{-# INLINE CONLIKE liftIOF #-} -liftIOF :: FixedEncoding a -> FixedEncoding (IO a) -liftIOF (FE l io) = FE l (\xWrapped op -> do x <- xWrapped; io x op) --} - ------------------------------------------------------------------------------- --- Bounded-size Encodings ------------------------------------------------------------------------------- - --- | An encoding that always results in sequence of bytes that is no longer --- than a pre-determined bound. -data BoundedEncoding a = BE {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO (Ptr Word8)) - --- | The bound on the size of sequences of bytes generated by this 'BoundedEncoding'. -{-# INLINE CONLIKE sizeBound #-} -sizeBound :: BoundedEncoding a -> Int -sizeBound (BE b _) = b - -boundedEncoding :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedEncoding a -boundedEncoding = BE - -{-# INLINE CONLIKE runB #-} -runB :: BoundedEncoding a -> a -> Ptr Word8 -> IO (Ptr Word8) -runB (BE _ io) = io - --- | Change a 'BoundedEncoding' such that it first applies a function to the --- value to be encoded. --- --- Note that 'BoundedEncoding's are 'Contrafunctors' --- . Hence, the following --- laws hold. --- --- >contramapB id = id --- >contramapB f . contramapB g = contramapB (g . f) -{-# INLINE CONLIKE contramapB #-} -contramapB :: (b -> a) -> BoundedEncoding a -> BoundedEncoding b -contramapB f (BE b io) = BE b (\x op -> io (f x) op) - --- | The 'BoundedEncoding' that always results in the zero-length sequence. -{-# INLINE CONLIKE emptyB #-} -emptyB :: BoundedEncoding a -emptyB = BE 0 (\_ op -> return op) - --- | Encode a pair by encoding its first component and then its second component. -{-# INLINE CONLIKE pairB #-} -pairB :: BoundedEncoding a -> BoundedEncoding b -> BoundedEncoding (a, b) -pairB (BE b1 io1) (BE b2 io2) = - BE (b1 + b2) (\(x1,x2) op -> io1 x1 op >>= io2 x2) - --- | Encode an 'Either' value using the first 'BoundedEncoding' for 'Left' --- values and the second 'BoundedEncoding' for 'Right' values. --- --- Note that the functions 'eitherB', 'pairB', and 'contramapB' (written below --- using '>$<') suffice to construct 'BoundedEncoding's for all non-recursive --- algebraic datatypes. For example, --- --- @ ---maybeB :: BoundedEncoding () -> BoundedEncoding a -> BoundedEncoding (Maybe a) ---maybeB nothing just = 'maybe' (Left ()) Right '>$<' eitherB nothing just --- @ -{-# INLINE CONLIKE eitherB #-} -eitherB :: BoundedEncoding a -> BoundedEncoding b -> BoundedEncoding (Either a b) -eitherB (BE b1 io1) (BE b2 io2) = - BE (max b1 b2) - (\x op -> case x of Left x1 -> io1 x1 op; Right x2 -> io2 x2 op) - --- | Conditionally select a 'BoundedEncoding'. --- For example, we can implement the ASCII encoding that drops characters with --- Unicode codepoints above 127 as follows. --- --- @ ---charASCIIDrop = 'ifB' (< '\128') ('fromF' 'char7') 'emptyB' --- @ -{-# INLINE CONLIKE ifB #-} -ifB :: (a -> Bool) -> BoundedEncoding a -> BoundedEncoding a -> BoundedEncoding a -ifB p be1 be2 = - contramapB (\x -> if p x then Left x else Right x) (eitherB be1 be2) - - -{- -{-# INLINE withSizeFB #-} -withSizeFB :: (Word -> FixedEncoding Word) -> BoundedEncoding a -> BoundedEncoding a -withSizeFB feSize (BE b io) = - BE (lSize + b) - (\x op0 -> do let !op1 = op0 `plusPtr` lSize - op2 <- io x op1 - ioSize (fromIntegral $ op2 `minusPtr` op1) op0 - return op2) - where - FE lSize ioSize = feSize (fromIntegral b) - - -{-# INLINE withSizeBB #-} -withSizeBB :: BoundedEncoding Word -> BoundedEncoding a -> BoundedEncoding a -withSizeBB (BE bSize ioSize) (BE b io) = - BE (bSize + 2*b) - (\x op0 -> do let !opTmp = op0 `plusPtr` (bSize + b) - opTmp' <- io x opTmp - let !s = opTmp' `minusPtr` opTmp - op1 <- ioSize (fromIntegral s) op0 - copyBytes op1 opTmp s - return $! op1 `plusPtr` s) - -{-# INLINE CONLIKE liftIOB #-} -liftIOB :: BoundedEncoding a -> BoundedEncoding (IO a) -liftIOB (BE l io) = BE l (\xWrapped op -> do x <- xWrapped; io x op) --} - ------------------------------------------------------------------------------- --- Encodings from 'ByteString's. ------------------------------------------------------------------------------- - -{- --- | A 'FixedEncoding' that always results in the same byte sequence given as a --- strict 'S.ByteString'. We can use this encoding to insert fixed ... -{-# INLINE CONLIKE constByteStringF #-} -constByteStringF :: S.ByteString -> FixedEncoding () -constByteStringF bs = - FE len io - where - (S.PS fp off len) = bs - io _ op = do - copyBytes op (unsafeForeignPtrToPtr fp `plusPtr` off) len - touchForeignPtr fp - --- | Encode a fixed-length prefix of a strict 'S.ByteString' as-is. We can use --- this function to -{-# INLINE byteStringPrefixB #-} -byteStringTakeB :: Int -- ^ Length of the prefix. It should be smaller than - -- 100 bytes, as otherwise - -> BoundedEncoding S.ByteString -byteStringTakeB n0 = - BE n io - where - n = max 0 n0 -- sanitize - - io (S.PS fp off len) op = do - let !s = min len n - copyBytes op (unsafeForeignPtrToPtr fp `plusPtr` off) s - touchForeignPtr fp - return $! op `plusPtr` s --} - -{- - -httpChunkedTransfer :: Builder -> Builder -httpChunkedTransfer = - encodeChunked 32 (word64HexFixedBound '0') - ((\_ -> ('\r',('\n',('\r','\n')))) >$< char8x4) - where - char8x4 = toB (char8 >*< char8 >*< char8 >*< char8) - - - -chunked :: Builder -> Builder -chunked = encodeChunked 16 word64VarFixedBound emptyB - --} - - - diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Base16.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Base16.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Base16.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Copyright : (c) 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : GHC --- --- Hexadecimal encoding of nibbles (4-bit) and octets (8-bit) as ASCII --- characters. --- --- The current implementation is based on a table based encoding inspired by --- the code in the 'base64-bytestring' library by Bryan O'Sullivan. In our --- benchmarks on a 32-bit machine it turned out to be the fastest --- implementation option. --- -module Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Base16 ( - EncodingTable - -- , upperTable - , lowerTable - , encode4_as_8 - , encode8_as_16h - -- , encode8_as_8_8 - ) where - -import qualified Data.ByteString as S -import qualified Data.ByteString.Internal as S - -#if MIN_VERSION_base(4,4,0) -import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import System.IO.Unsafe (unsafePerformIO) -#else -import Foreign -#endif - --- Creating the encoding tables -------------------------------- - --- TODO: Use table from C implementation. - --- | An encoding table for Base16 encoding. -newtype EncodingTable = EncodingTable (ForeignPtr Word8) - -tableFromList :: [Word8] -> EncodingTable -tableFromList xs = case S.pack xs of S.PS fp _ _ -> EncodingTable fp - -unsafeIndex :: EncodingTable -> Int -> IO Word8 -unsafeIndex (EncodingTable table) = peekElemOff (unsafeForeignPtrToPtr table) - -base16EncodingTable :: EncodingTable -> IO EncodingTable -base16EncodingTable alphabet = do - xs <- sequence $ concat $ [ [ix j, ix k] | j <- [0..15], k <- [0..15] ] - return $ tableFromList xs - where - ix = unsafeIndex alphabet - -{- -{-# NOINLINE upperAlphabet #-} -upperAlphabet :: EncodingTable -upperAlphabet = - tableFromList $ map (fromIntegral . fromEnum) $ ['0'..'9'] ++ ['A'..'F'] - --- | The encoding table for hexadecimal values with upper-case characters; --- e.g., DEADBEEF. -{-# NOINLINE upperTable #-} -upperTable :: EncodingTable -upperTable = unsafePerformIO $ base16EncodingTable upperAlphabet --} - -{-# NOINLINE lowerAlphabet #-} -lowerAlphabet :: EncodingTable -lowerAlphabet = - tableFromList $ map (fromIntegral . fromEnum) $ ['0'..'9'] ++ ['a'..'f'] - --- | The encoding table for hexadecimal values with lower-case characters; --- e.g., deadbeef. -{-# NOINLINE lowerTable #-} -lowerTable :: EncodingTable -lowerTable = unsafePerformIO $ base16EncodingTable lowerAlphabet - - --- Encoding nibbles and octets ------------------------------- - --- | Encode a nibble as an octet. --- --- > encode4_as_8 lowerTable 10 = fromIntegral (char 'a') --- -{-# INLINE encode4_as_8 #-} -encode4_as_8 :: EncodingTable -> Word8 -> IO Word8 -encode4_as_8 table x = unsafeIndex table (2 * fromIntegral x + 1) --- TODO: Use a denser table to reduce cache utilization. - --- | Encode an octet as 16bit word comprising both encoded nibbles ordered --- according to the host endianness. Writing these 16bit to memory will write --- the nibbles in the correct order (i.e. big-endian). -{-# INLINE encode8_as_16h #-} -encode8_as_16h :: EncodingTable -> Word8 -> IO Word16 -encode8_as_16h (EncodingTable table) = - peekElemOff (castPtr $ unsafeForeignPtrToPtr table) . fromIntegral - -{- --- | Encode an octet as a big-endian ordered tuple of octets; i.e., --- --- > encode8_as_8_8 lowerTable 10 --- > = (fromIntegral (chr '0'), fromIntegral (chr 'a')) --- -{-# INLINE encode8_as_8_8 #-} -encode8_as_8_8 :: EncodingTable -> Word8 -> IO (Word8, Word8) -encode8_as_8_8 table x = - (,) <$> unsafeIndex table i <*> unsafeIndex table (i + 1) - where - i = 2 * fromIntegral x --} diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Floating.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Floating.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Floating.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- | --- Copyright : (c) 2010 Simon Meier --- --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : GHC --- --- Conversion of 'Float's and 'Double's to 'Word32's and 'Word64's. --- -module Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Floating - ( - -- coerceFloatToWord32 - -- , coerceDoubleToWord64 - encodeFloatViaWord32F - , encodeDoubleViaWord64F - ) where - -import Foreign -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal - -{- -We work around ticket http://hackage.haskell.org/trac/ghc/ticket/4092 using the -FFI to store the Float/Double in the buffer and peek it out again from there. --} - - --- | Encode a 'Float' using a 'Word32' encoding. --- --- PRE: The 'Word32' encoding must have a size of at least 4 bytes. -{-# INLINE encodeFloatViaWord32F #-} -encodeFloatViaWord32F :: FixedEncoding Word32 -> FixedEncoding Float -encodeFloatViaWord32F w32fe - | size w32fe < sizeOf (undefined :: Float) = - error $ "encodeFloatViaWord32F: encoding not wide enough" - | otherwise = fixedEncoding (size w32fe) $ \x op -> do - poke (castPtr op) x - x' <- peek (castPtr op) - runF w32fe x' op - --- | Encode a 'Double' using a 'Word64' encoding. --- --- PRE: The 'Word64' encoding must have a size of at least 8 bytes. -{-# INLINE encodeDoubleViaWord64F #-} -encodeDoubleViaWord64F :: FixedEncoding Word64 -> FixedEncoding Double -encodeDoubleViaWord64F w64fe - | size w64fe < sizeOf (undefined :: Float) = - error $ "encodeDoubleViaWord64F: encoding not wide enough" - | otherwise = fixedEncoding (size w64fe) $ \x op -> do - poke (castPtr op) x - x' <- peek (castPtr op) - runF w64fe x' op - diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/UncheckedShifts.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/UncheckedShifts.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/UncheckedShifts.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE CPP, MagicHash #-} --- | --- Copyright : (c) 2010 Simon Meier --- --- Original serialization code from 'Data.Binary.Builder': --- (c) Lennart Kolmodin, Ross Patterson --- --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC --- --- Utilty module defining unchecked shifts. --- --- These functions are undefined when the amount being shifted by is --- greater than the size in bits of a machine Int#.- --- -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -#include "MachDeps.h" -#endif - -module Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts ( - shiftr_w16 - , shiftr_w32 - , shiftr_w64 - , shiftr_w - - , caseWordSize_32_64 - ) where - - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -import GHC.Base -import GHC.Word (Word32(..),Word16(..),Word64(..)) - -#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 -import GHC.Word (uncheckedShiftRL64#) -#endif -#else -import Data.Word -#endif - -import Foreign - - ------------------------------------------------------------------------- --- Unchecked shifts - --- | Right-shift of a 'Word16'. -{-# INLINE shiftr_w16 #-} -shiftr_w16 :: Word16 -> Int -> Word16 - --- | Right-shift of a 'Word32'. -{-# INLINE shiftr_w32 #-} -shiftr_w32 :: Word32 -> Int -> Word32 - --- | Right-shift of a 'Word64'. -{-# INLINE shiftr_w64 #-} -shiftr_w64 :: Word64 -> Int -> Word64 - --- | Right-shift of a 'Word'. -{-# INLINE shiftr_w #-} -shiftr_w :: Word -> Int -> Word -#if WORD_SIZE_IN_BITS < 64 -shiftr_w w s = fromIntegral $ (`shiftr_w32` s) $ fromIntegral w -#else -shiftr_w w s = fromIntegral $ (`shiftr_w64` s) $ fromIntegral w -#endif - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) -shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) - -#if WORD_SIZE_IN_BITS < 64 -shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) - -#if __GLASGOW_HASKELL__ <= 606 --- Exported by GHC.Word in GHC 6.8 and higher -foreign import ccall unsafe "stg_uncheckedShiftRL64" - uncheckedShiftRL64# :: Word64# -> Int# -> Word64# -#endif - -#else -shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) -#endif - -#else -shiftr_w16 = shiftR -shiftr_w32 = shiftR -shiftr_w64 = shiftR -#endif - - --- | Select an implementation depending on the bit-size of 'Word's. --- Currently, it produces a runtime failure if the bitsize is different. --- This is detected by the testsuite. -{-# INLINE caseWordSize_32_64 #-} -caseWordSize_32_64 :: a -- Value to use for 32-bit 'Word's - -> a -- Value to use for 64-bit 'Word's - -> a -caseWordSize_32_64 f32 f64 = case bitSize (undefined :: Word) of - 32 -> f32 - 64 -> f64 - s -> error $ "caseWordSize_32_64: unsupported Word bit-size " ++ show s - - diff --git a/Data/ByteString/Lazy/Builder/Extras.hs b/Data/ByteString/Lazy/Builder/Extras.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/Extras.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE BangPatterns #-} ------------------------------------------------------------------------------ --- | Copyright : (c) 2010 Jasper Van der Jeugt --- (c) 2010-2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC --- --- Extra functions for creating and executing 'Builder's. They are intended --- for application-specific fine-tuning the performance of 'Builder's. --- ------------------------------------------------------------------------------ -module Data.ByteString.Lazy.Builder.Extras - ( - -- * Execution strategies - toLazyByteStringWith - , AllocationStrategy - , safeStrategy - , untrimmedStrategy - , smallChunkSize - , defaultChunkSize - - -- * Controlling chunk boundaries - , byteStringCopy - , byteStringInsert - , byteStringThreshold - - , lazyByteStringCopy - , lazyByteStringInsert - , lazyByteStringThreshold - - , flush - - -- * Host-specific binary encodings - , intHost - , int16Host - , int32Host - , int64Host - - , wordHost - , word16Host - , word32Host - , word64Host - - , floatHost - , doubleHost - - ) where - - -import Data.ByteString.Lazy.Builder.Internal - -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E - - -import Foreign - - - ------------------------------------------------------------------------------- --- Host-specific encodings ------------------------------------------------------------------------------- - --- | Encode a single native machine 'Int'. The 'Int' is encoded in host order, --- host endian form, for the machine you're on. On a 64 bit machine the 'Int' --- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way --- are not portable to different endian or int sized machines, without --- conversion. --- -{-# INLINE intHost #-} -intHost :: Int -> Builder -intHost = E.encodeWithF E.intHost - --- | Encode a 'Int16' in native host order and host endianness. -{-# INLINE int16Host #-} -int16Host :: Int16 -> Builder -int16Host = E.encodeWithF E.int16Host - --- | Encode a 'Int32' in native host order and host endianness. -{-# INLINE int32Host #-} -int32Host :: Int32 -> Builder -int32Host = E.encodeWithF E.int32Host - --- | Encode a 'Int64' in native host order and host endianness. -{-# INLINE int64Host #-} -int64Host :: Int64 -> Builder -int64Host = E.encodeWithF E.int64Host - --- | Encode a single native machine 'Word'. The 'Word' is encoded in host order, --- host endian form, for the machine you're on. On a 64 bit machine the 'Word' --- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way --- are not portable to different endian or word sized machines, without --- conversion. --- -{-# INLINE wordHost #-} -wordHost :: Word -> Builder -wordHost = E.encodeWithF E.wordHost - --- | Encode a 'Word16' in native host order and host endianness. -{-# INLINE word16Host #-} -word16Host :: Word16 -> Builder -word16Host = E.encodeWithF E.word16Host - --- | Encode a 'Word32' in native host order and host endianness. -{-# INLINE word32Host #-} -word32Host :: Word32 -> Builder -word32Host = E.encodeWithF E.word32Host - --- | Encode a 'Word64' in native host order and host endianness. -{-# INLINE word64Host #-} -word64Host :: Word64 -> Builder -word64Host = E.encodeWithF E.word64Host - --- | Encode a 'Float' in native host order. Values encoded this way are not --- portable to different endian machines, without conversion. -{-# INLINE floatHost #-} -floatHost :: Float -> Builder -floatHost = E.encodeWithF E.floatHost - --- | Encode a 'Double' in native host order. -{-# INLINE doubleHost #-} -doubleHost :: Double -> Builder -doubleHost = E.encodeWithF E.doubleHost - diff --git a/Data/ByteString/Lazy/Builder/Internal.hs b/Data/ByteString/Lazy/Builder/Internal.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/Internal.hs +++ /dev/null @@ -1,854 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns, Rank2Types #-} -{-# OPTIONS_HADDOCK hide #-} --- | Copyright : (c) 2010 - 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : GHC --- --- Core types and functions for the 'Builder' monoid and its generalization, --- the 'Put' monad. --- --- The design of the 'Builder' monoid is optimized such that --- --- 1. buffers of arbitrary size can be filled as efficiently as possible and --- --- 2. sequencing of 'Builder's is as cheap as possible. --- --- We achieve (1) by completely handing over control over writing to the buffer --- to the 'BuildStep' implementing the 'Builder'. This 'BuildStep' is just told --- the start and the end of the buffer (represented as a 'BufferRange'). Then, --- the 'BuildStep' can write to as big a prefix of this 'BufferRange' in any --- way it desires. If the 'BuildStep' is done, the 'BufferRange' is full, or a --- long sequence of bytes should be inserted directly, then the 'BuildStep' --- signals this to its caller using a 'BuildSignal'. --- --- We achieve (2) by requiring that every 'Builder' is implemented by a --- 'BuildStep' that takes a continuation 'BuildStep', which it calls with the --- updated 'BufferRange' after it is done. Therefore, only two pointers have --- to be passed in a function call to implement concatenation of 'Builder's. --- Moreover, many 'Builder's are completely inlined, which enables the compiler --- to sequence them without a function call and with no boxing at all. --- --- This design gives the implementation of a 'Builder' full access to the 'IO' --- monad. Therefore, utmost care has to be taken to not overwrite anything --- outside the given 'BufferRange's. Moreover, further care has to be taken to --- ensure that 'Builder's and 'Put's are referentially transparent. See the --- comments of the 'builder' and 'put' functions for further information. --- Note that there are /no safety belts/ at all, when implementing a 'Builder' --- using an 'IO' action: you are writing code that might enable the next --- buffer-overflow attack on a Haskell server! --- -module Data.ByteString.Lazy.Builder.Internal ( - - -- * Build signals and steps - BufferRange(..) - , LazyByteStringC - - , BuildSignal - , BuildStep - - , done - , bufferFull - , insertChunks - - , fillWithBuildStep - - -- * The Builder monoid - , Builder - , builder - , runBuilder - , runBuilderWith - - -- ** Primitive combinators - , empty - , append - , flush - , ensureFree - - , byteStringCopy - , byteStringInsert - , byteStringThreshold - - , lazyByteStringCopy - , lazyByteStringInsert - , lazyByteStringThreshold - - , lazyByteStringC - - , maximalCopySize - , byteString - , lazyByteString - - -- ** Execution strategies - , toLazyByteStringWith - , AllocationStrategy - , safeStrategy - , untrimmedStrategy - , L.smallChunkSize - , L.defaultChunkSize - - -- * The Put monad - , Put - , put - , runPut - , hPut - - -- ** Streams of chunks interleaved with IO - , ChunkIOStream(..) - , buildStepToCIOS - , ciosToLazyByteString - - -- ** Conversion to and from Builders - , putBuilder - , fromPut - - -- ** Lifting IO actions - -- , putLiftIO - -) where - -import Control.Applicative (Applicative(..), (<$>)) - -import Data.Monoid -import qualified Data.ByteString as S -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy.Internal as L - -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO.Buffer (Buffer(..), newByteBuffer) -import GHC.IO.Handle.Internals (wantWritableHandle, flushWriteBuffer) -import GHC.IO.Handle.Types (Handle__, haByteBuffer, haBufferMode) -import System.IO (hFlush, BufferMode(..)) -import Data.IORef -#else -import qualified Data.ByteString.Lazy as L -#endif -import System.IO (Handle) - -#if MIN_VERSION_base(4,4,0) -import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import System.IO.Unsafe (unsafePerformIO) -#else -import Foreign -#endif - - -type LazyByteStringC = L.ByteString -> L.ByteString - --- | A range of bytes in a buffer represented by the pointer to the first byte --- of the range and the pointer to the first byte /after/ the range. -data BufferRange = BufferRange {-# UNPACK #-} !(Ptr Word8) -- First byte of range - {-# UNPACK #-} !(Ptr Word8) -- First byte /after/ range - - ------------------------------------------------------------------------------- --- Build signals ------------------------------------------------------------------------------- - --- | 'BuildStep's may assume that they are called at most once. However, --- they must not execute any function that may rise an async. exception, --- as this would invalidate the code of 'hPut' below. -type BuildStep a = BufferRange -> IO (BuildSignal a) - --- | 'BuildSignal's abstract signals to the caller of a 'BuildStep'. There are --- exactly three signals: 'done', 'bufferFull', and 'insertChunks'. -data BuildSignal a = - Done {-# UNPACK #-} !(Ptr Word8) a - | BufferFull - {-# UNPACK #-} !Int - {-# UNPACK #-} !(Ptr Word8) - !(BuildStep a) - | InsertChunks - {-# UNPACK #-} !(Ptr Word8) - {-# UNPACK #-} !Int64 -- size of bytes in continuation - LazyByteStringC - !(BuildStep a) - --- | Signal that the current 'BuildStep' is done and has computed a value. -{-# INLINE done #-} -done :: Ptr Word8 -- ^ Next free byte in current 'BufferRange' - -> a -- ^ Computed value - -> BuildSignal a -done = Done - --- | Signal that the current buffer is full. -{-# INLINE bufferFull #-} -bufferFull :: Int - -- ^ Minimal size of next 'BufferRange'. - -> Ptr Word8 - -- ^ Next free byte in current 'BufferRange'. - -> BuildStep a - -- ^ 'BuildStep' to run on the next 'BufferRange'. This 'BuildStep' - -- may assume that it is called with a 'BufferRange' of at least the - -- required minimal size; i.e., the caller of this 'BuildStep' must - -- guarantee this. - -> BuildSignal a -bufferFull = BufferFull - --- TODO: Decide whether we should inline the bytestring constructor. --- Therefore, making builders independent of strict bytestrings. - --- | Signal that several chunks should be inserted directly. -{-# INLINE insertChunks #-} -insertChunks :: Ptr Word8 - -- ^ Next free byte in current 'BufferRange' - -> Int64 - -- ^ Number of bytes in 'L.ByteString' continuation. - -> (L.ByteString -> L.ByteString) - -- ^ Chunks to insert. - -> BuildStep a - -- ^ 'BuildStep' to run on next 'BufferRange' - -> BuildSignal a -insertChunks = InsertChunks - --- | Fill a 'BufferRange' using a 'BuildStep'. -{-# INLINE fillWithBuildStep #-} -fillWithBuildStep - :: BuildStep a - -- ^ Build step to use for filling the 'BufferRange'. - -> (Ptr Word8 -> a -> IO b) - -- ^ Handling the 'done' signal - -> (Ptr Word8 -> Int -> BuildStep a -> IO b) - -- ^ Handling the 'bufferFull' signal - -> (Ptr Word8 -> Int64 -> LazyByteStringC -> BuildStep a -> IO b) - -- ^ Handling the 'insertChunks' signal - -> BufferRange - -- ^ Buffer range to fill. - -> IO b - -- ^ Value computed by filling this 'BufferRange'. -fillWithBuildStep step fDone fFull fChunk !br = do - signal <- step br - case signal of - Done op x -> fDone op x - BufferFull minSize op nextStep -> fFull op minSize nextStep - InsertChunks op len lbsC nextStep -> fChunk op len lbsC nextStep - - - ------------------------------------------------------------------------------- --- The 'Builder' monoid ------------------------------------------------------------------------------- - --- | 'Builder's denote sequences of bytes. --- They are 'Monoid's where --- 'mempty' is the zero-length sequence and --- 'mappend' is concatenation, which runs in /O(1)/. -newtype Builder = Builder (forall r. BuildStep r -> BuildStep r) - --- | Construct a 'Builder'. In contrast to 'BuildStep's, 'Builder's are --- referentially transparent. -{-# INLINE builder #-} -builder :: (forall r. BuildStep r -> BuildStep r) - -- ^ A function that fills a 'BufferRange', calls the continuation with - -- the updated 'BufferRange' once its done, and signals its caller how - -- to proceed using 'done', 'bufferFull', or 'insertChunk'. - -- - -- This function must be referentially transparent; i.e., calling it - -- multiple times must result in the same sequence of bytes being - -- written. If you need mutable state, then you must allocate it newly - -- upon each call of this function. Moroever, this function must call - -- the continuation once its done. Otherwise, concatenation of - -- 'Builder's does not work. Finally, this function must write to all - -- bytes that it claims it has written. Otherwise, the resulting - -- 'Builder' is not guaranteed to be referentially transparent and - -- sensitive data might leak. - -> Builder -builder = Builder - --- | Run a 'Builder'. -{-# INLINE runBuilder #-} -runBuilder :: Builder -- ^ 'Builder' to run - -> BuildStep () -- ^ 'BuildStep' that writes the byte stream of this - -- 'Builder' and signals 'done' upon completion. -runBuilder (Builder b) = b $ \(BufferRange op _) -> return $ done op () - --- | Run a 'Builder'. -{-# INLINE runBuilderWith #-} -runBuilderWith :: Builder -- ^ 'Builder' to run - -> BuildStep a -- ^ Continuation 'BuildStep' - -> BuildStep a -runBuilderWith (Builder b) = b - --- | The 'Builder' denoting a zero-length sequence of bytes. This function is --- only exported for use in rewriting rules. Use 'mempty' otherwise. -{-# INLINE[1] empty #-} -empty :: Builder -empty = Builder id - --- | Concatenate two 'Builder's. This function is only exported for use in rewriting --- rules. Use 'mappend' otherwise. -{-# INLINE[1] append #-} -append :: Builder -> Builder -> Builder -append (Builder b1) (Builder b2) = Builder $ b1 . b2 - -instance Monoid Builder where - {-# INLINE mempty #-} - mempty = empty - {-# INLINE mappend #-} - mappend = append - {-# INLINE mconcat #-} - mconcat = foldr mappend mempty - --- | Flush the current buffer. This introduces a chunk boundary. --- -{-# INLINE flush #-} -flush :: Builder -flush = builder step - where - step k !(BufferRange op _) = return $ insertChunks op 0 id k - - ------------------------------------------------------------------------------- --- Put ------------------------------------------------------------------------------- - --- | A 'Put' action denotes a computation of a value that writes a stream of --- bytes as a side-effect. 'Put's are strict in their side-effect; i.e., the --- stream of bytes will always be written before the computed value is --- returned. --- --- 'Put's are a generalization of 'Builder's. They are used when values need to --- be returned during the computation of a stream of bytes. For example, when --- performing a block-based encoding of 'S.ByteString's like Base64 encoding, --- there might be a left-over partial block. Using the 'Put' monad, this --- partial block can be returned after the complete blocks have been encoded. --- Then, in a later step when more input is known, this partial block can be --- completed and also encoded. --- --- @Put ()@ actions are isomorphic to 'Builder's. The functions 'putBuilder' --- and 'fromPut' convert between these two types. Where possible, you should --- use 'Builder's, as they are slightly cheaper than 'Put's because they do not --- carry a computed value. -newtype Put a = Put { unPut :: forall r. (a -> BuildStep r) -> BuildStep r } - --- | Construct a 'Put' action. In contrast to 'BuildStep's, 'Put's are --- referentially transparent in the sense that sequencing the same 'Put' --- multiple times yields every time the same value with the same side-effect. -{-# INLINE put #-} -put :: (forall r. (a -> BuildStep r) -> BuildStep r) - -- ^ A function that fills a 'BufferRange', calls the continuation with - -- the updated 'BufferRange' and its computed value once its done, and - -- signals its caller how to proceed using 'done', 'bufferFull', or - -- 'insertChunk'. - -- - -- This function must be referentially transparent; i.e., calling it - -- multiple times must result in the same sequence of bytes being - -- written and the same value being computed. If you need mutable state, - -- then you must allocate it newly upon each call of this function. - -- Moroever, this function must call the continuation once its done. - -- Otherwise, monadic sequencing of 'Put's does not work. Finally, this - -- function must write to all bytes that it claims it has written. - -- Otherwise, the resulting 'Put' is not guaranteed to be referentially - -- transparent and sensitive data might leak. - -> Put a -put = Put - --- | Run a 'Put'. -{-# INLINE runPut #-} -runPut :: Put a -- ^ Put to run - -> BuildStep a -- ^ 'BuildStep' that first writes the byte stream of - -- this 'Put' and then yields the computed value using - -- the 'done' signal. -runPut (Put p) = p $ \x (BufferRange op _) -> return $ Done op x - -instance Functor Put where - fmap f p = Put $ \k -> unPut p (\x -> k (f x)) - {-# INLINE fmap #-} - -instance Applicative Put where - {-# INLINE pure #-} - pure x = Put $ \k -> k x - {-# INLINE (<*>) #-} - Put f <*> Put a = Put $ \k -> f (\f' -> a (\a' -> k (f' a'))) -#if MIN_VERSION_base(4,2,0) - {-# INLINE (<*) #-} - Put a <* Put b = Put $ \k -> a (\a' -> b (\_ -> k a')) - {-# INLINE (*>) #-} - Put a *> Put b = Put $ \k -> a (\_ -> b k) -#endif - -instance Monad Put where - {-# INLINE return #-} - return x = Put $ \k -> k x - {-# INLINE (>>=) #-} - Put m >>= f = Put $ \k -> m (\m' -> unPut (f m') k) - {-# INLINE (>>) #-} - Put m >> Put n = Put $ \k -> m (\_ -> n k) - - --- Conversion between Put and Builder -------------------------------------- - --- | Run a 'Builder' as a side-effect of a @Put ()@ action. -{-# INLINE putBuilder #-} -putBuilder :: Builder -> Put () -putBuilder (Builder b) = Put $ \k -> b (k ()) - --- | Convert a @Put ()@ action to a 'Builder'. -{-# INLINE fromPut #-} -fromPut :: Put () -> Builder -fromPut (Put p) = Builder $ \k -> p (\_ -> k) - - --- Lifting IO actions ---------------------- - -{- --- | Lift an 'IO' action to a 'Put' action. -{-# INLINE putLiftIO #-} -putLiftIO :: IO a -> Put a -putLiftIO io = put $ \k br -> io >>= (`k` br) --} - - ------------------------------------------------------------------------------- --- Executing a Put directly on a buffered Handle ------------------------------------------------------------------------------- - --- | Run a 'Put' action redirecting the produced output to a 'Handle'. --- --- The output is buffered using the 'Handle's associated buffer. If this --- buffer is too small to execute one step of the 'Put' action, then --- it is replaced with a large enough buffer. -hPut :: forall a. Handle -> Put a -> IO a -#if __GLASGOW_HASKELL__ >= 611 -hPut h p = do - fillHandle 1 (runPut p) - where - fillHandle :: Int -> BuildStep a -> IO a - fillHandle !minFree step = do - next <- wantWritableHandle "hPut" h fillHandle_ - next - where - -- | We need to return an inner IO action that is executed outside - -- the lock taken on the Handle for two reasons: - -- - -- 1. GHC.IO.Handle.Internals mentions in "Note [async]" that - -- we should never do any side-effecting operations before - -- an interruptible operation that may raise an async. exception - -- as long as we are inside 'wantWritableHandle' and the like. - -- We possibly run the interuptible 'flushWriteBuffer' right at - -- the start of 'fillHandle', hence entering it a second time is - -- not safe, as it could lead to a 'BuildStep' being run twice. - -- - -- 2. We use the 'S.hPut' function to also write to the handle. - -- This function tries to take the same lock taken by - -- 'wantWritableHandle'. Therefore, we cannot call 'S.hPut' - -- inside 'wantWritableHandle'. - -- - fillHandle_ :: Handle__ -> IO (IO a) - fillHandle_ h_ = do - makeSpace =<< readIORef refBuf - fillBuffer =<< readIORef refBuf - where - refBuf = haByteBuffer h_ - freeSpace buf = bufSize buf - bufR buf - - makeSpace buf - | bufSize buf < minFree = do - flushWriteBuffer h_ - s <- bufState <$> readIORef refBuf - newByteBuffer minFree s >>= writeIORef refBuf - - | freeSpace buf < minFree = flushWriteBuffer h_ - | otherwise = -#if __GLASGOW_HASKELL__ >= 613 - return () -#else - -- required for ghc-6.12 - flushWriteBuffer h_ -#endif - - fillBuffer buf - | freeSpace buf < minFree = - error $ unlines - [ "Data.ByteString.Lazy.Builder.Internal.hPut: internal error." - , " Not enough space after flush." - , " required: " ++ show minFree - , " free: " ++ show (freeSpace buf) - ] - | otherwise = do - let !br = BufferRange op (pBuf `plusPtr` bufSize buf) - res <- fillWithBuildStep step doneH fullH insertChunksH br - touchForeignPtr fpBuf - return res - where - fpBuf = bufRaw buf - pBuf = unsafeForeignPtrToPtr fpBuf - op = pBuf `plusPtr` bufR buf - - {-# INLINE updateBufR #-} - updateBufR op' = do - let !off' = op' `minusPtr` pBuf - !buf' = buf {bufR = off'} - writeIORef refBuf buf' - - doneH op' x = do - updateBufR op' - -- We must flush if this Handle is set to NoBuffering. - -- If it is set to LineBuffering, be conservative and - -- flush anyway (we didn't check for newlines in the data). - -- Flushing must happen outside this 'wantWriteableHandle' - -- due to the possible async. exception. - case haBufferMode h_ of - BlockBuffering _ -> return $ return x - _line_or_no_buffering -> return $ hFlush h >> return x - - fullH op' minSize nextStep = do - updateBufR op' - return $ fillHandle minSize nextStep - -- 'fillHandle' will flush the buffer (provided there is - -- really less than 'minSize' space left) before executing - -- the 'nextStep'. - - insertChunksH op' _ lbsC nextStep = do - updateBufR op' - return $ do - L.foldrChunks (\c rest -> S.hPut h c >> rest) (return ()) - (lbsC L.Empty) - fillHandle 1 nextStep -#else -hPut h p = - go =<< buildStepToCIOS strategy (return . Finished) (runPut p) - where - go (Finished k) = return k - go (Yield1 bs io) = S.hPut h bs >> io >>= go - go (YieldC _ lbsC io) = L.hPut h (lbsC L.Empty) >> io >>= go - strategy = untrimmedStrategy L.smallChunkSize L.defaultChunkSize -#endif - ------------------------------------------------------------------------------- --- ByteString insertion / controlling chunk boundaries ------------------------------------------------------------------------------- - --- Raw memory -------------- - --- | Ensure that there are at least 'n' free bytes for the following 'Builder'. -{-# INLINE ensureFree #-} -ensureFree :: Int -> Builder -ensureFree minFree = - builder step - where - step k br@(BufferRange op ope) - | ope `minusPtr` op < minFree = return $ bufferFull minFree op k - | otherwise = k br - --- | Copy the bytes from a 'BufferRange' into the output stream. -{-# INLINE bytesCopyStep #-} -bytesCopyStep :: BufferRange -- ^ Input 'BufferRange'. - -> BuildStep a -> BuildStep a -bytesCopyStep !(BufferRange ip0 ipe) k = - go ip0 - where - go !ip !(BufferRange op ope) - | inpRemaining <= outRemaining = do - copyBytes op ip inpRemaining - let !br' = BufferRange (op `plusPtr` inpRemaining) ope - k br' - | otherwise = do - copyBytes op ip outRemaining - let !ip' = ip `plusPtr` outRemaining - return $ bufferFull 1 ope (go ip') - where - outRemaining = ope `minusPtr` op - inpRemaining = ipe `minusPtr` ip - - - --- Strict ByteStrings ------------------------------------------------------------------------------- - - --- | Construct a 'Builder' that copies the strict 'S.ByteString's, if it is --- smaller than the treshold, and inserts it directly otherwise. --- --- For example, @byteStringThreshold 1024@ copies strict 'S.ByteString's whose size --- is less or equal to 1kb, and inserts them directly otherwise. This implies --- that the average chunk-size of the generated lazy 'L.ByteString' may be as --- low as 513 bytes, as there could always be just a single byte between the --- directly inserted 1025 byte, strict 'S.ByteString's. --- -{-# INLINE byteStringThreshold #-} -byteStringThreshold :: Int -> S.ByteString -> Builder -byteStringThreshold maxCopySize = - \bs -> builder $ step bs - where - step !bs@(S.PS _ _ len) !k br@(BufferRange !op _) - | len <= maxCopySize = byteStringCopyStep bs k br - | otherwise = - return $! insertChunks op (fromIntegral len) (L.chunk bs) k - --- | Construct a 'Builder' that copies the strict 'S.ByteString'. --- --- Use this function to create 'Builder's from smallish (@<= 4kb@) --- 'S.ByteString's or if you need to guarantee that the 'S.ByteString' is not --- shared with the chunks generated by the 'Builder'. --- -{-# INLINE byteStringCopy #-} -byteStringCopy :: S.ByteString -> Builder -byteStringCopy = \bs -> builder $ byteStringCopyStep bs - -{-# INLINE byteStringCopyStep #-} -byteStringCopyStep :: S.ByteString -> BuildStep a -> BuildStep a -byteStringCopyStep (S.PS ifp ioff isize) !k0 = - bytesCopyStep (BufferRange ip ipe) k - where - ip = unsafeForeignPtrToPtr ifp `plusPtr` ioff - ipe = ip `plusPtr` isize - k br = do touchForeignPtr ifp -- input consumed: OK to release here - k0 br - --- | Construct a 'Builder' that always inserts the strict 'S.ByteString' --- directly as a chunk. --- --- This implies flushing the output buffer, even if it contains just --- a single byte. You should therefore use 'byteStringInsert' only for large --- (@> 8kb@) 'S.ByteString's. Otherwise, the generated chunks are too --- fragmented to be processed efficiently afterwards. --- -{-# INLINE byteStringInsert #-} -byteStringInsert :: S.ByteString -> Builder -byteStringInsert = - \bs -> builder $ step bs - where - step !bs k !br@(BufferRange op _) - | S.null bs = k br - | otherwise = - return $ insertChunks op (fromIntegral $ S.length bs) (L.Chunk bs) k - - --- Lazy bytestrings ------------------------------------------------------------------------------- - --- | Construct a 'Builder' that uses the thresholding strategy of 'byteStringThreshold' --- for each chunk of the lazy 'L.ByteString'. --- -{-# INLINE lazyByteStringThreshold #-} -lazyByteStringThreshold :: Int -> L.ByteString -> Builder -lazyByteStringThreshold maxCopySize = - L.foldrChunks (\bs b -> byteStringThreshold maxCopySize bs `mappend` b) mempty - -- TODO: We could do better here. Currently, Large, Small, Large, leads to - -- an unnecessary copy of the 'Small' chunk. - --- | Construct a 'Builder' that copies the lazy 'L.ByteString'. --- -{-# INLINE lazyByteStringCopy #-} -lazyByteStringCopy :: L.ByteString -> Builder -lazyByteStringCopy = - L.foldrChunks (\bs b -> byteStringCopy bs `mappend` b) mempty - - --- | Construct a 'Builder' that inserts all chunks of the lazy 'L.ByteString' --- directly. --- -{-# INLINE lazyByteStringInsert #-} -lazyByteStringInsert :: L.ByteString -> Builder -lazyByteStringInsert = - \lbs -> builder $ step lbs - where - step L.Empty k br = k br - step lbs k (BufferRange op _) = case go 0 id lbs of - (n, lbsC) -> return $ insertChunks op n lbsC k - - go !n lbsC L.Empty = (n, lbsC) - go !n lbsC (L.Chunk bs lbs) = - go (n + fromIntegral (S.length bs)) (lbsC . L.Chunk bs) lbs - - --- | Create a 'Builder' denoting the same sequence of bytes as a strict --- 'S.ByteString'. --- The 'Builder' inserts large 'S.ByteString's directly, but copies small ones --- to ensure that the generated chunks are large on average. --- -{-# INLINE byteString #-} -byteString :: S.ByteString -> Builder -byteString = byteStringThreshold maximalCopySize - --- | Create a 'Builder' denoting the same sequence of bytes as a lazy --- 'S.ByteString'. --- The 'Builder' inserts large chunks of the lazy 'L.ByteString' directly, --- but copies small ones to ensure that the generated chunks are large on --- average. --- -{-# INLINE lazyByteString #-} -lazyByteString :: L.ByteString -> Builder -lazyByteString = lazyByteStringThreshold maximalCopySize --- FIXME: also insert the small chunk for [large,small,large] directly. --- Perhaps it makes even sense to concatenate the small chunks in --- [large,small,small,small,large] and insert them directly afterwards to avoid --- unnecessary buffer spilling. Hmm, but that uncontrollably increases latency --- => no good! - --- | The maximal size of a 'S.ByteString' that is copied. --- @2 * 'L.smallChunkSize'@ to guarantee that on average a chunk is of --- 'L.smallChunkSize'. -maximalCopySize :: Int -maximalCopySize = 2 * L.smallChunkSize - --- LazyByteStringC: difference lists of lazy bytestrings --------------------------------------------------------- - --- | Insert a 'LazyByteStringC' of the given size directly. -{-# INLINE lazyByteStringC #-} -lazyByteStringC :: Int64 -> LazyByteStringC -> Builder -lazyByteStringC n lbsC = - builder $ \k (BufferRange op _) -> return $ insertChunks op n lbsC k - ------------------------------------------------------------------------------- --- Builder execution ------------------------------------------------------------------------------- - --- | A buffer allocation strategy for executing 'Builder's. - --- The strategy --- --- > 'AllocationStrategy' firstBufSize bufSize trim --- --- states that the first buffer is of size @firstBufSize@, all following buffers --- are of size @bufSize@, and a buffer of size @n@ filled with @k@ bytes should --- be trimmed iff @trim k n@ is 'True'. -data AllocationStrategy = AllocationStrategy - {-# UNPACK #-} !Int -- size of first buffer - {-# UNPACK #-} !Int -- size of successive buffers - (Int -> Int -> Bool) -- trim - --- | Sanitize a buffer size; i.e., make it at least the size of a 'Int'. -{-# INLINE sanitize #-} -sanitize :: Int -> Int -sanitize = max (sizeOf (undefined :: Int)) - --- | Use this strategy for generating lazy 'L.ByteString's whose chunks are --- discarded right after they are generated. For example, if you just generate --- them to write them to a network socket. -{-# INLINE untrimmedStrategy #-} -untrimmedStrategy :: Int -- ^ Size of the first buffer - -> Int -- ^ Size of successive buffers - -> AllocationStrategy - -- ^ An allocation strategy that does not trim any of the - -- filled buffers before converting it to a chunk. -untrimmedStrategy firstSize bufSize = - AllocationStrategy (sanitize firstSize) (sanitize bufSize) (\_ _ -> False) - - --- | Use this strategy for generating lazy 'L.ByteString's whose chunks are --- likely to survive one garbage collection. This strategy trims buffers --- that are filled less than half in order to avoid spilling too much memory. -{-# INLINE safeStrategy #-} -safeStrategy :: Int -- ^ Size of first buffer - -> Int -- ^ Size of successive buffers - -> AllocationStrategy - -- ^ An allocation strategy that guarantees that at least half - -- of the allocated memory is used for live data -safeStrategy firstSize bufSize = - AllocationStrategy (sanitize firstSize) (sanitize bufSize) - (\used size -> 2*used < size) - --- | Execute a 'Builder' with custom execution parameters. --- --- This function is forced to be inlined to allow fusing with the allocation --- strategy despite its rather heavy code-size. We therefore recommend --- that you introduce a top-level function once you have fixed your strategy. --- This avoids unnecessary code duplication. --- For example, the default 'Builder' execution function 'toLazyByteString' is --- defined as follows. --- --- @ --- {-# NOINLINE toLazyByteString #-} --- toLazyByteString = --- toLazyByteStringWith ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') empty --- @ --- --- where @empty@ is the zero-length lazy 'L.ByteString'. --- --- In most cases, the parameters used by 'toLazyByteString' give good --- performance. A sub-performing case of 'toLazyByteString' is executing short --- (<128 bytes) 'Builder's. In this case, the allocation overhead for the first --- 4kb buffer and the trimming cost dominate the cost of executing the --- 'Builder'. You can avoid this problem using --- --- >toLazyByteStringWith (safeStrategy 128 smallChunkSize) empty --- --- This reduces the allocation and trimming overhead, as all generated --- 'L.ByteString's fit into the first buffer and there is no trimming --- required, if more than 64 bytes are written. --- -{-# INLINE toLazyByteStringWith #-} -toLazyByteStringWith - :: AllocationStrategy - -- ^ Buffer allocation strategy to use - -> L.ByteString - -- ^ Lazy 'L.ByteString' to use as the tail of the generated lazy - -- 'L.ByteString' - -> Builder - -- ^ Builder to execute - -> L.ByteString - -- ^ Resulting lazy 'L.ByteString' -toLazyByteStringWith strategy k b = - ciosToLazyByteString k $ unsafePerformIO $ - buildStepToCIOS strategy (return . Finished) (runBuilder b) - --- | A stream of non-empty chunks interleaved with 'IO'. -data ChunkIOStream a = - Finished a - | Yield1 {-# UNPACK #-} !S.ByteString (IO (ChunkIOStream a)) - | YieldC {-# UNPACK #-} !Int64 LazyByteStringC (IO (ChunkIOStream a)) - -{-# INLINE ciosToLazyByteString #-} -ciosToLazyByteString :: L.ByteString -> ChunkIOStream () -> L.ByteString -ciosToLazyByteString k = go - where - go (Finished _) = k - go (Yield1 bs io) = L.Chunk bs $ unsafePerformIO (go <$> io) - go (YieldC _ lbsC io) = lbsC $ unsafePerformIO (go <$> io) - -{-# INLINE buildStepToCIOS #-} -buildStepToCIOS - :: AllocationStrategy -- ^ Buffer allocation strategy to use - -> (a -> IO (ChunkIOStream b)) -- ^ Continuation stream constructor. - -> BuildStep a -- ^ 'Put' to execute - -> IO (ChunkIOStream b) -buildStepToCIOS (AllocationStrategy firstSize bufSize trim) k = - \step -> fillNew step firstSize - where - fillNew !step0 !size = do - S.mallocByteString size >>= fill step0 - where - fill !step !fpbuf = do - res <- fillWithBuildStep step doneH fullH insertChunksH br - touchForeignPtr fpbuf - return res - where - op = unsafeForeignPtrToPtr fpbuf -- safe due to mkCIOS - pe = op `plusPtr` size - br = BufferRange op pe - - doneH op' x = wrapChunk op' (const $ k x) - - fullH op' minSize nextStep = - wrapChunk op' (const $ fillNew nextStep (max minSize bufSize)) - - insertChunksH op' n lbsC nextStep = - wrapChunk op' $ \isEmpty -> return $ YieldC n lbsC $ - -- Checking for empty case avoids allocating 'n-1' empty - -- buffers for 'n' insertChunksH right after each other. - if isEmpty - then fill nextStep fpbuf - else fillNew nextStep bufSize - - -- Yield a chunk, trimming it if necesary - {-# INLINE wrapChunk #-} - wrapChunk !op' mkCIOS - | pe < op' = error $ - "buildStepToCIOS: overwrite by " ++ show (op' `minusPtr` pe) ++ " bytes" - | chunkSize == 0 = mkCIOS True - | trim chunkSize size = do - bs <- S.create chunkSize $ \pbuf -> copyBytes pbuf op chunkSize - return $ Yield1 bs (mkCIOS False) - | otherwise = - return $ Yield1 (S.PS fpbuf 0 chunkSize) (mkCIOS False) - where - chunkSize = op' `minusPtr` op diff --git a/Data/ByteString/Lazy/Char8.hs b/Data/ByteString/Lazy/Char8.hs --- a/Data/ByteString/Lazy/Char8.hs +++ b/Data/ByteString/Lazy/Char8.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_HADDOCK prune #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif +{-# OPTIONS_HADDOCK prune #-} + -- | -- Module : Data.ByteString.Lazy.Char8 -- Copyright : (c) Don Stewart 2006-2008 @@ -33,137 +31,176 @@ module Data.ByteString.Lazy.Char8 ( -- * The @ByteString@ type - ByteString, -- instances: Eq, Ord, Show, Read, Data, Typeable + ByteString, -- * Introducing and eliminating 'ByteString's - empty, -- :: ByteString - singleton, -- :: Char -> ByteString - pack, -- :: String -> ByteString - unpack, -- :: ByteString -> String - fromChunks, -- :: [Strict.ByteString] -> ByteString - toChunks, -- :: ByteString -> [Strict.ByteString] - fromStrict, -- :: Strict.ByteString -> ByteString - toStrict, -- :: ByteString -> Strict.ByteString + empty, + singleton, + pack, + unpack, + fromChunks, + toChunks, + fromStrict, + toStrict, -- * Basic interface - cons, -- :: Char -> ByteString -> ByteString - cons', -- :: Char -> ByteString -> ByteString - snoc, -- :: ByteString -> Char -> ByteString - append, -- :: ByteString -> ByteString -> ByteString - head, -- :: ByteString -> Char - uncons, -- :: ByteString -> Maybe (Char, ByteString) - last, -- :: ByteString -> Char - tail, -- :: ByteString -> ByteString - init, -- :: ByteString -> ByteString - null, -- :: ByteString -> Bool - length, -- :: ByteString -> Int64 + cons, + cons', + snoc, + append, + head, + uncons, + last, + tail, + unsnoc, + init, + null, + length, -- * Transforming ByteStrings - map, -- :: (Char -> Char) -> ByteString -> ByteString - reverse, -- :: ByteString -> ByteString - intersperse, -- :: Char -> ByteString -> ByteString - intercalate, -- :: ByteString -> [ByteString] -> ByteString - transpose, -- :: [ByteString] -> [ByteString] + map, + reverse, + intersperse, + intercalate, + transpose, -- * Reducing 'ByteString's (folds) - foldl, -- :: (a -> Char -> a) -> a -> ByteString -> a - foldl', -- :: (a -> Char -> a) -> a -> ByteString -> a - foldl1, -- :: (Char -> Char -> Char) -> ByteString -> Char - foldl1', -- :: (Char -> Char -> Char) -> ByteString -> Char - foldr, -- :: (Char -> a -> a) -> a -> ByteString -> a - foldr1, -- :: (Char -> Char -> Char) -> ByteString -> Char + foldl, + foldl', + foldl1, + foldl1', + foldr, + foldr', + foldr1, + foldr1', -- ** Special folds - concat, -- :: [ByteString] -> ByteString - concatMap, -- :: (Char -> ByteString) -> ByteString -> ByteString - any, -- :: (Char -> Bool) -> ByteString -> Bool - all, -- :: (Char -> Bool) -> ByteString -> Bool - maximum, -- :: ByteString -> Char - minimum, -- :: ByteString -> Char + concat, + concatMap, + any, + all, + maximum, + minimum, + compareLength, -- * Building ByteStrings -- ** Scans - scanl, -- :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString --- scanl1, -- :: (Char -> Char -> Char) -> ByteString -> ByteString --- scanr, -- :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString --- scanr1, -- :: (Char -> Char -> Char) -> ByteString -> ByteString + scanl, + scanl1, + scanr, + scanr1, -- ** Accumulating maps - mapAccumL, -- :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString) - mapAccumR, -- :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString) + mapAccumL, + mapAccumR, -- ** Infinite ByteStrings - repeat, -- :: Char -> ByteString - replicate, -- :: Int64 -> Char -> ByteString - cycle, -- :: ByteString -> ByteString - iterate, -- :: (Char -> Char) -> Char -> ByteString + repeat, + replicate, + cycle, + iterate, -- ** Unfolding ByteStrings - unfoldr, -- :: (a -> Maybe (Char, a)) -> a -> ByteString + unfoldr, -- * Substrings -- ** Breaking strings - take, -- :: Int64 -> ByteString -> ByteString - drop, -- :: Int64 -> ByteString -> ByteString - splitAt, -- :: Int64 -> ByteString -> (ByteString, ByteString) - takeWhile, -- :: (Char -> Bool) -> ByteString -> ByteString - dropWhile, -- :: (Char -> Bool) -> ByteString -> ByteString - span, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) - break, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) - group, -- :: ByteString -> [ByteString] - groupBy, -- :: (Char -> Char -> Bool) -> ByteString -> [ByteString] - inits, -- :: ByteString -> [ByteString] - tails, -- :: ByteString -> [ByteString] + take, + takeEnd, + drop, + dropEnd, + splitAt, + takeWhile, + takeWhileEnd, + dropWhile, + dropWhileEnd, + span, + spanEnd, + break, + breakEnd, + group, + groupBy, + inits, + tails, + initsNE, + tailsNE, + stripPrefix, + stripSuffix, -- ** Breaking into many substrings - split, -- :: Char -> ByteString -> [ByteString] - splitWith, -- :: (Char -> Bool) -> ByteString -> [ByteString] + split, + splitWith, -- ** Breaking into lines and words - lines, -- :: ByteString -> [ByteString] - words, -- :: ByteString -> [ByteString] - unlines, -- :: [ByteString] -> ByteString - unwords, -- :: ByteString -> [ByteString] + lines, + words, + unlines, + unwords, -- * Predicates - isPrefixOf, -- :: ByteString -> ByteString -> Bool --- isSuffixOf, -- :: ByteString -> ByteString -> Bool + isPrefixOf, + isSuffixOf, -- * Searching ByteStrings -- ** Searching by equality - elem, -- :: Char -> ByteString -> Bool - notElem, -- :: Char -> ByteString -> Bool + elem, + notElem, -- ** Searching with a predicate - find, -- :: (Char -> Bool) -> ByteString -> Maybe Char - filter, -- :: (Char -> Bool) -> ByteString -> ByteString --- partition -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) + find, + filter, + partition, -- * Indexing ByteStrings - index, -- :: ByteString -> Int64 -> Char - elemIndex, -- :: Char -> ByteString -> Maybe Int64 - elemIndices, -- :: Char -> ByteString -> [Int64] - findIndex, -- :: (Char -> Bool) -> ByteString -> Maybe Int64 - findIndices, -- :: (Char -> Bool) -> ByteString -> [Int64] - count, -- :: Char -> ByteString -> Int64 + index, + indexMaybe, + (!?), + elemIndex, + elemIndexEnd, + elemIndices, + findIndex, + findIndexEnd, + findIndices, + count, -- * Zipping and unzipping ByteStrings - zip, -- :: ByteString -> ByteString -> [(Char,Char)] - zipWith, -- :: (Char -> Char -> c) -> ByteString -> ByteString -> [c] --- unzip, -- :: [(Char,Char)] -> (ByteString,ByteString) + zip, + zipWith, + packZipWith, + unzip, -- * Ordered ByteStrings --- sort, -- :: ByteString -> ByteString +-- sort, -- * Low level conversions -- ** Copying ByteStrings - copy, -- :: ByteString -> ByteString + copy, -- * Reading from ByteStrings + -- | Note that a lazy 'ByteString' may hold an unbounded stream of + -- @\'0\'@ digits, in which case the functions below may never return. + -- If that's a concern, you can use 'take' to first truncate the input + -- to an acceptable length. Non-termination is also possible when + -- reading arbitrary precision numbers via 'readInteger' or + -- 'readNatural', if the input is an unbounded stream of arbitrary + -- decimal digits. + -- readInt, + readInt64, + readInt32, + readInt16, + readInt8, + + readWord, + readWord64, + readWord32, + readWord16, + readWord8, + readInteger, + readNatural, -- * I\/O with 'ByteString's -- | ByteString I/O uses binary mode, without any character decoding @@ -171,68 +208,62 @@ -- newline mode is considered a flaw and may be changed in a future version. -- ** Standard input and output - getContents, -- :: IO ByteString - putStr, -- :: ByteString -> IO () - putStrLn, -- :: ByteString -> IO () - interact, -- :: (ByteString -> ByteString) -> IO () + getContents, + putStr, + putStrLn, + interact, -- ** Files - readFile, -- :: FilePath -> IO ByteString - writeFile, -- :: FilePath -> ByteString -> IO () - appendFile, -- :: FilePath -> ByteString -> IO () + readFile, + writeFile, + appendFile, -- ** I\/O with Handles - hGetContents, -- :: Handle -> IO ByteString - hGet, -- :: Handle -> Int64 -> IO ByteString - hGetNonBlocking, -- :: Handle -> Int64 -> IO ByteString - hPut, -- :: Handle -> ByteString -> IO () - hPutNonBlocking, -- :: Handle -> ByteString -> IO ByteString - hPutStr, -- :: Handle -> ByteString -> IO () - hPutStrLn, -- :: Handle -> ByteString -> IO () + hGetContents, + hGet, + hGetNonBlocking, + hPut, + hPutNonBlocking, + hPutStr, + hPutStrLn, ) where -- Functions transparently exported -import Data.ByteString.Lazy - (fromChunks, toChunks, fromStrict, toStrict +import Data.ByteString.Lazy + (fromChunks, toChunks ,empty,null,length,tail,init,append,reverse,transpose,cycle - ,concat,take,drop,splitAt,intercalate,isPrefixOf,group,inits,tails,copy + ,concat,take,takeEnd,drop,dropEnd,splitAt,intercalate + ,isPrefixOf,isSuffixOf,group,inits,tails,initsNE,tailsNE,copy + ,stripPrefix,stripSuffix ,hGetContents, hGet, hPut, getContents ,hGetNonBlocking, hPutNonBlocking - ,putStr, hPutStr, interact) + ,putStr, hPutStr, interact + ,readFile,writeFile,appendFile,compareLength) -- Functions we need to wrap. import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S (ByteString) -- typename only import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as B +import Data.List.NonEmpty (NonEmpty(..)) import Data.ByteString.Lazy.Internal +import Data.ByteString.Lazy.ReadInt +import Data.ByteString.Lazy.ReadNat -import Data.ByteString.Internal (w2c, c2w, isSpaceWord8) +import Data.ByteString.Internal (c2w,w2c,isSpaceWord8) import Data.Int (Int64) import qualified Data.List as List -import Prelude hiding - (reverse,head,tail,last,init,null,length,map,lines,foldl,foldr,unlines - ,concat,any,take,drop,splitAt,takeWhile,dropWhile,span,break,elem,filter - ,unwords,words,maximum,minimum,all,concatMap,scanl,scanl1,foldl1,foldr1 +import Prelude hiding + (reverse,head,tail,last,init,Foldable(..),map,lines,unlines + ,concat,any,take,drop,splitAt,takeWhile,dropWhile,span,break,filter + ,unwords,words,all,concatMap,scanl,scanl1,scanr,scanr1 ,readFile,writeFile,appendFile,replicate,getContents,getLine,putStr,putStrLn ,zip,zipWith,unzip,notElem,repeat,iterate,interact,cycle) -import System.IO (Handle,stdout,hClose,openFile,IOMode(..)) -#ifndef __NHC__ -import Control.Exception (bracket) -#else -import IO (bracket) -#endif - -#define STRICT1(f) f a | a `seq` False = undefined -#define STRICT2(f) f a b | a `seq` b `seq` False = undefined -#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined -#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined -#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined -#define STRICT5_(f) f a b c d _ | a `seq` b `seq` c `seq` d `seq` False = undefined +import System.IO (Handle, stdout) ------------------------------------------------------------------------ @@ -241,7 +272,7 @@ singleton = L.singleton . c2w {-# INLINE singleton #-} --- | /O(n)/ Convert a 'String' into a 'ByteString'. +-- | /O(n)/ Convert a 'String' into a 'ByteString'. pack :: [Char] -> ByteString pack = packChars @@ -252,12 +283,12 @@ infixr 5 `cons`, `cons'` --same as list (:) infixl 5 `snoc` --- | /O(1)/ 'cons' is analogous to '(:)' for lists. +-- | /O(1)/ 'cons' is analogous to '(Prelude.:)' for lists. cons :: Char -> ByteString -> ByteString cons = L.cons . c2w {-# INLINE cons #-} --- | /O(1)/ Unlike 'cons', 'cons\'' is +-- | /O(1)/ Unlike 'cons', 'cons'' is -- strict in the ByteString that we are consing onto. More precisely, it forces -- the head and the first chunk. It does this because, for space efficiency, it -- may coalesce the new byte onto the first \'chunk\' rather than starting a @@ -265,7 +296,7 @@ -- -- So that means you can't use a lazy recursive contruction like this: -- --- > let xs = cons\' c xs in xs +-- > let xs = cons' c xs in xs -- -- You can however use 'cons', as well as 'repeat' and 'cycle', to build -- infinite lazy ByteStrings. @@ -293,6 +324,14 @@ Just (w, bs') -> Just (w2c w, bs') {-# INLINE uncons #-} +-- | /O(n\/c)/ Extract the 'init' and 'last' of a ByteString, returning Nothing +-- if it is empty. +unsnoc :: ByteString -> Maybe (ByteString, Char) +unsnoc bs = case L.unsnoc bs of + Nothing -> Nothing + Just (bs', w) -> Just (bs', w2c w) +{-# INLINE unsnoc #-} + -- | /O(1)/ Extract the last element of a packed string, which must be non-empty. last :: ByteString -> Char last = w2c . L.last @@ -317,7 +356,7 @@ foldl f = L.foldl (\a c -> f a (w2c c)) {-# INLINE foldl #-} --- | 'foldl\'' is like foldl, but strict in the accumulator. +-- | 'foldl'' is like foldl, but strict in the accumulator. foldl' :: (a -> Char -> a) -> a -> ByteString -> a foldl' f = L.foldl' (\a c -> f a (w2c c)) {-# INLINE foldl' #-} @@ -326,16 +365,22 @@ -- (typically the right-identity of the operator), and a packed string, -- reduces the packed string using the binary operator, from right to left. foldr :: (Char -> a -> a) -> a -> ByteString -> a -foldr f = L.foldr (\c a -> f (w2c c) a) +foldr f = L.foldr (f . w2c) {-# INLINE foldr #-} +-- | 'foldr'' is like 'foldr', but strict in the accumulator. +-- +-- @since 0.11.2.0 +foldr' :: (Char -> a -> a) -> a -> ByteString -> a +foldr' f = L.foldr' (f . w2c) + -- | 'foldl1' is a variant of 'foldl' that has no starting value --- argument, and thus must be applied to non-empty 'ByteStrings'. +-- argument, and thus must be applied to non-empty 'ByteString's. foldl1 :: (Char -> Char -> Char) -> ByteString -> Char foldl1 f ps = w2c (L.foldl1 (\x y -> c2w (f (w2c x) (w2c y))) ps) {-# INLINE foldl1 #-} --- | 'foldl1\'' is like 'foldl1', but strict in the accumulator. +-- | 'foldl1'' is like 'foldl1', but strict in the accumulator. foldl1' :: (Char -> Char -> Char) -> ByteString -> Char foldl1' f ps = w2c (L.foldl1' (\x y -> c2w (f (w2c x) (w2c y))) ps) @@ -345,6 +390,12 @@ foldr1 f ps = w2c (L.foldr1 (\x y -> c2w (f (w2c x) (w2c y))) ps) {-# INLINE foldr1 #-} +-- | 'foldr1'' is like 'foldr1', but strict in the accumulator. +-- +-- @since 0.11.2.0 +foldr1' :: (Char -> Char -> Char) -> ByteString -> Char +foldr1' f ps = w2c (L.foldr1' (\x y -> c2w (f (w2c x) (w2c y))) ps) + -- | Map a function over a 'ByteString' and concatenate the results concatMap :: (Char -> ByteString) -> ByteString -> ByteString concatMap f = L.concatMap (f . w2c) @@ -376,7 +427,7 @@ -- Building ByteStrings -- | 'scanl' is similar to 'foldl', but returns a list of successive --- reduced values from the left. This function will fuse. +-- reduced values from the left. -- -- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] -- @@ -386,6 +437,45 @@ scanl :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString scanl f z = L.scanl (\a b -> c2w (f (w2c a) (w2c b))) (c2w z) +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument. +-- +-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] +-- +-- @since 0.11.2.0 +scanl1 :: (Char -> Char -> Char) -> ByteString -> ByteString +scanl1 f = L.scanl1 f' + where f' accumulator value = c2w (f (w2c accumulator) (w2c value)) + +-- | 'scanr' is similar to 'foldr', but returns a list of successive +-- reduced values from the right. +-- +-- > scanr f z [..., x{n-1}, xn] == [..., x{n-1} `f` (xn `f` z), xn `f` z, z] +-- +-- Note that +-- +-- > head (scanr f z xs) == foldr f z xs +-- > last (scanr f z xs) == z +-- +-- @since 0.11.2.0 +scanr + :: (Char -> Char -> Char) + -- ^ element -> accumulator -> new accumulator + -> Char + -- ^ starting value of accumulator + -> ByteString + -- ^ input of length n + -> ByteString + -- ^ output of length n+1 +scanr f = L.scanr f' . c2w + where f' accumulator value = c2w (f (w2c accumulator) (w2c value)) + +-- | 'scanr1' is a variant of 'scanr' that has no starting value argument. +-- +-- @since 0.11.2.0 +scanr1 :: (Char -> Char -> Char) -> ByteString -> ByteString +scanr1 f = L.scanr1 f' + where f' accumulator value = c2w (f (w2c accumulator) (w2c value)) + -- | The 'mapAccumL' function behaves like a combination of 'map' and -- 'foldl'; it applies a function to each element of a ByteString, -- passing an accumulating parameter from left to right, and returning a @@ -443,27 +533,73 @@ takeWhile f = L.takeWhile (f . w2c) {-# INLINE takeWhile #-} +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate. +-- +-- @'takeWhileEnd' p@ is equivalent to @'reverse' . 'takeWhile' p . 'reverse'@. +-- +-- @since 0.11.2.0 +takeWhileEnd :: (Char -> Bool) -> ByteString -> ByteString +takeWhileEnd f = L.takeWhileEnd (f . w2c) +{-# INLINE takeWhileEnd #-} + -- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@. dropWhile :: (Char -> Bool) -> ByteString -> ByteString dropWhile f = L.dropWhile (f . w2c) {-# INLINE dropWhile #-} +-- | Similar to 'P.dropWhileEnd', +-- drops the longest (possibly empty) suffix of elements +-- satisfying the predicate and returns the remainder. +-- +-- @'dropWhileEnd' p@ is equivalent to @'reverse' . 'dropWhile' p . 'reverse'@. +-- +-- @since 0.11.2.0 +dropWhileEnd :: (Char -> Bool) -> ByteString -> ByteString +dropWhileEnd f = L.dropWhileEnd (f . w2c) +{-# INLINE dropWhileEnd #-} + -- | 'break' @p@ is equivalent to @'span' ('not' . p)@. break :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) break f = L.break (f . w2c) {-# INLINE break #-} +-- | 'breakEnd' behaves like 'break' but from the end of the 'ByteString' +-- +-- breakEnd p == spanEnd (not.p) +-- +-- @since 0.11.2.0 +breakEnd :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) +breakEnd f = L.breakEnd (f . w2c) +{-# INLINE breakEnd #-} + -- | 'span' @p xs@ breaks the ByteString into two segments. It is -- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@ span :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) span f = L.span (f . w2c) {-# INLINE span #-} +-- | 'spanEnd' behaves like 'span' but from the end of the 'ByteString'. +-- We have +-- +-- > spanEnd (not.isSpace) "x y z" == ("x y ","z") +-- +-- and +-- +-- > spanEnd (not . isSpace) ps +-- > == +-- > let (x,y) = span (not.isSpace) (reverse ps) in (reverse y, reverse x) +-- +-- @since 0.11.2.0 +spanEnd :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) +spanEnd f = L.spanEnd (f . w2c) +{-# INLINE spanEnd #-} + {- --- | 'breakChar' breaks its ByteString argument at the first occurence +-- | 'breakChar' breaks its ByteString argument at the first occurrence -- of the specified Char. It is more efficient than 'break' as it is -- implemented with @memchr(3)@. I.e. --- +-- -- > break (=='c') "abcd" == breakChar 'c' "abcd" -- breakChar :: Char -> ByteString -> (ByteString, ByteString) @@ -471,7 +607,7 @@ {-# INLINE breakChar #-} -- | 'spanChar' breaks its ByteString argument at the first --- occurence of a Char other than its argument. It is more efficient +-- occurrence of a Char other than its argument. It is more efficient -- than 'span (==)' -- -- > span (=='c') "abcd" == spanByte 'c' "abcd" @@ -491,14 +627,15 @@ -- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"] -- > split 'a' "aXaXaXa" == ["","X","X","X"] -- > split 'x' "x" == ["",""] --- +-- > split undefined "" == [] -- and not [""] +-- -- and -- -- > intercalate [c] . split c == id -- > split == splitWith . (==) --- +-- -- As for all splitting functions in this library, this function does --- not copy the substrings, it just constructs new 'ByteStrings' that +-- not copy the substrings, it just constructs new 'ByteString's that -- are slices of the original. -- split :: Char -> ByteString -> [ByteString] @@ -511,6 +648,7 @@ -- separators result in an empty component in the output. eg. -- -- > splitWith (=='a') "aabbaca" == ["","","bb","c",""] +-- > splitWith undefined "" == [] -- and not [""] -- splitWith :: (Char -> Bool) -> ByteString -> [ByteString] splitWith f = L.splitWith (f . w2c) @@ -525,6 +663,24 @@ index = (w2c .) . L.index {-# INLINE index #-} +-- | /O(1)/ 'ByteString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 0.11.0.0 +indexMaybe :: ByteString -> Int64 -> Maybe Char +indexMaybe = (fmap w2c .) . L.indexMaybe +{-# INLINE indexMaybe #-} + +-- | /O(1)/ 'ByteString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 0.11.0.0 +(!?) :: ByteString -> Int64 -> Maybe Char +(!?) = indexMaybe +{-# INLINE (!?) #-} + -- | /O(n)/ The 'elemIndex' function returns the index of the first -- element in the given 'ByteString' which is equal (by memchr) to the -- query element, or 'Nothing' if there is no such element. @@ -532,6 +688,20 @@ elemIndex = L.elemIndex . c2w {-# INLINE elemIndex #-} +-- | /O(n)/ The 'elemIndexEnd' function returns the last index of the +-- element in the given 'ByteString' which is equal to the query +-- element, or 'Nothing' if there is no such element. The following +-- holds: +-- +-- > elemIndexEnd c xs = case elemIndex c (reverse xs) of +-- > Nothing -> Nothing +-- > Just i -> Just (length xs - 1 - i) +-- +-- @since 0.11.1.0 +elemIndexEnd :: Char -> ByteString -> Maybe Int64 +elemIndexEnd = L.elemIndexEnd . c2w +{-# INLINE elemIndexEnd #-} + -- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning -- the indices of all elements equal to the query element, in ascending order. elemIndices :: Char -> ByteString -> [Int64] @@ -544,10 +714,20 @@ findIndex f = L.findIndex (f . w2c) {-# INLINE findIndex #-} +-- | The 'findIndexEnd' function takes a predicate and a 'ByteString' and +-- returns the index of the last element in the ByteString +-- satisfying the predicate. +-- +-- @since 0.11.1.0 +findIndexEnd :: (Char -> Bool) -> ByteString -> Maybe Int64 +findIndexEnd f = L.findIndexEnd (f . w2c) +{-# INLINE findIndexEnd #-} + -- | The 'findIndices' function extends 'findIndex', by returning the -- indices of all elements satisfying the predicate, in ascending order. findIndices :: (Char -> Bool) -> ByteString -> [Int64] findIndices f = L.findIndices (f . w2c) +{-# INLINE findIndices #-} -- | count returns the number of times its argument appears in the ByteString -- @@ -576,6 +756,11 @@ filter f = L.filter (f . w2c) {-# INLINE filter #-} +-- | @since 0.10.12.0 +partition :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) +partition f = L.partition (f . w2c) +{-# INLINE partition #-} + {- -- | /O(n)/ and /O(n\/c) space/ A first order equivalent of /filter . -- (==)/, for the common case of filtering a single Char. It is more @@ -653,88 +838,75 @@ zipWith :: (Char -> Char -> a) -> ByteString -> ByteString -> [a] zipWith f = L.zipWith ((. w2c) . f . w2c) --- | 'lines' breaks a ByteString up into a list of ByteStrings at --- newline Chars. The resulting strings do not contain newlines. --- --- As of bytestring 0.9.0.3, this function is stricter than its --- list cousin. +-- | A specialised version of `zipWith` for the common case of a +-- simultaneous map over two ByteStrings, to build a 3rd. -- -lines :: ByteString -> [ByteString] -lines Empty = [] -lines (Chunk c0 cs0) = loop0 c0 cs0 +-- @since 0.11.1.0 +packZipWith :: (Char -> Char -> Char) -> ByteString -> ByteString -> ByteString +packZipWith f = L.packZipWith f' where - -- this is a really performance sensitive function but the - -- chunked representation makes the general case a bit expensive - -- however assuming a large chunk size and normalish line lengths - -- we will find line endings much more frequently than chunk - -- endings so it makes sense to optimise for that common case. - -- So we partition into two special cases depending on whether we - -- are keeping back a list of chunks that will eventually be output - -- once we get to the end of the current line. - - -- the common special case where we have no existing chunks of - -- the current line - loop0 :: S.ByteString -> ByteString -> [ByteString] - loop0 c cs = - case B.elemIndex (c2w '\n') c of - Nothing -> case cs of - Empty | B.null c -> [] - | otherwise -> Chunk c Empty : [] - (Chunk c' cs') - | B.null c -> loop0 c' cs' - | otherwise -> loop c' [c] cs' - - Just n | n /= 0 -> Chunk (B.unsafeTake n c) Empty - : loop0 (B.unsafeDrop (n+1) c) cs - | otherwise -> Empty - : loop0 (B.unsafeTail c) cs - - -- the general case when we are building a list of chunks that are - -- part of the same line - loop :: S.ByteString -> [S.ByteString] -> ByteString -> [ByteString] - loop c line cs = - case B.elemIndex (c2w '\n') c of - Nothing -> - case cs of - Empty -> let c' = revChunks (c : line) - in c' `seq` (c' : []) - - (Chunk c' cs') -> loop c' (c : line) cs' - - Just n -> - let c' = revChunks (B.unsafeTake n c : line) - in c' `seq` (c' : loop0 (B.unsafeDrop (n+1) c) cs) - -{- - -This function is too strict! Consider, - -> prop_lazy = - (L.unpack . head . lazylines $ L.append (L.pack "a\nb\n") (error "failed")) - == - "a" + f' c1 c2 = c2w $ f (w2c c1) (w2c c2) +{-# INLINE packZipWith #-} -fails. Here's a properly lazy version of 'lines' for lazy bytestrings +-- | /O(n)/ 'unzip' transforms a list of pairs of chars into a pair of +-- ByteStrings. Note that this performs two 'pack' operations. +-- +-- @since 0.11.1.0 +unzip :: [(Char, Char)] -> (ByteString, ByteString) +unzip ls = (pack (fmap fst ls), pack (fmap snd ls)) +{-# INLINE unzip #-} - lazylines :: L.ByteString -> [L.ByteString] - lazylines s - | L.null s = [] - | otherwise = - let (l,s') = L.break ((==) '\n') s - in l : if L.null s' then [] - else lazylines (L.tail s') +-- | 'lines' lazily splits a ByteString into a list of ByteStrings at +-- newline Chars (@'\\n'@). The resulting strings do not contain newlines. +-- The first chunk of the result is only strict in the first chunk of the +-- input. +-- +-- Note that it __does not__ regard CR (@'\\r'@) as a newline character. +-- +lines :: ByteString -> [ByteString] +lines Empty = [] +lines (Chunk c0 cs0) = unNE $! go c0 cs0 + where + -- Natural NonEmpty -> List + unNE :: NonEmpty a -> [a] + unNE (a :| b) = a : b -we need a similarly lazy, but efficient version. + -- Strict in the first argument, lazy in the second. + consNE :: ByteString -> NonEmpty ByteString -> NonEmpty ByteString + consNE !a b = a :| (unNE $! b) --} + -- Note invariant: The initial chunk is non-empty on input, and we + -- need to be sure to maintain this in internal recursive calls. + go :: S.ByteString -> ByteString -> NonEmpty ByteString + go c cs = case B.elemIndex (c2w '\n') c of + Just n + | n1 <- n + 1 + , n1 < B.length c -> consNE c' $ go (B.unsafeDrop n1 c) cs + -- 'c' was a multi-line chunk + | otherwise -> c' :| lines cs + -- 'c' was a single-line chunk + where + !c' = chunk (B.unsafeTake n c) Empty + -- Initial chunk with no new line becomes first chunk of + -- first line of result, with the rest of the result lazy! + -- In particular, we don't strictly pattern match on 'cs'. + -- + -- We can form `Chunk c ...` because the invariant is maintained + -- here and also by using `chunk` in the defintion of `c'` above. + Nothing -> let ~(l:|ls) = lazyRest cs + in Chunk c l :| ls + where + lazyRest :: ByteString -> NonEmpty ByteString + lazyRest (Chunk c' cs') = go c' cs' + lazyRest Empty = Empty :| [] --- | 'unlines' is an inverse operation to 'lines'. It joins lines, --- after appending a terminating newline to each. +-- | 'unlines' joins lines, appending a terminating newline after each. +-- +-- Equivalent to +-- @'concat' . Data.List.concatMap (\\x -> [x, 'singleton' \'\\n'])@. unlines :: [ByteString] -> ByteString -unlines [] = empty -unlines ss = (concat $ List.intersperse nl ss) `append` nl -- half as much space - where nl = singleton '\n' +unlines = List.foldr (\x t -> x `append` cons '\n' t) Empty -- | 'words' breaks a ByteString up into a list of words, which -- were delimited by Chars representing white space. And @@ -750,131 +922,22 @@ unwords = intercalate (singleton ' ') {-# INLINE unwords #-} --- | readInt reads an Int from the beginning of the ByteString. If --- there is no integer at the beginning of the string, it returns --- Nothing, otherwise it just returns the int read, and the rest of the --- string. - -{- --- Faster: - -data MaybeS = NothingS - | JustS {-# UNPACK #-} !Int {-# UNPACK #-} !ByteString --} - -readInt :: ByteString -> Maybe (Int, ByteString) -{-# INLINE readInt #-} -readInt Empty = Nothing -readInt (Chunk x xs) = case w2c (B.unsafeHead x) of - '-' -> loop True 0 0 (B.unsafeTail x) xs - '+' -> loop False 0 0 (B.unsafeTail x) xs - _ -> loop False 0 0 x xs - - where loop :: Bool -> Int -> Int - -> S.ByteString -> ByteString -> Maybe (Int, ByteString) - STRICT5_(loop) - loop neg i n c cs - | B.null c = case cs of - Empty -> end neg i n c cs - (Chunk c' cs') -> loop neg i n c' cs' - | otherwise = - case B.unsafeHead c of - w | w >= 0x30 - && w <= 0x39 -> loop neg (i+1) - (n * 10 + (fromIntegral w - 0x30)) - (B.unsafeTail c) cs - | otherwise -> end neg i n c cs - - {-# INLINE end #-} - end _ 0 _ _ _ = Nothing - end neg _ n c cs = e `seq` e - where n' = if neg then negate n else n - c' = chunk c cs - e = n' `seq` c' `seq` Just $! (n',c') - -- in n' `seq` c' `seq` JustS n' c' - - --- | readInteger reads an Integer from the beginning of the ByteString. If --- there is no integer at the beginning of the string, it returns Nothing, --- otherwise it just returns the int read, and the rest of the string. -readInteger :: ByteString -> Maybe (Integer, ByteString) -readInteger Empty = Nothing -readInteger (Chunk c0 cs0) = - case w2c (B.unsafeHead c0) of - '-' -> first (B.unsafeTail c0) cs0 >>= \(n, cs') -> return (-n, cs') - '+' -> first (B.unsafeTail c0) cs0 - _ -> first c0 cs0 - - where first c cs - | B.null c = case cs of - Empty -> Nothing - (Chunk c' cs') -> first' c' cs' - | otherwise = first' c cs - - first' c cs = case B.unsafeHead c of - w | w >= 0x30 && w <= 0x39 -> Just $ - loop 1 (fromIntegral w - 0x30) [] (B.unsafeTail c) cs - | otherwise -> Nothing - - loop :: Int -> Int -> [Integer] - -> S.ByteString -> ByteString -> (Integer, ByteString) - STRICT5_(loop) - loop d acc ns c cs - | B.null c = case cs of - Empty -> combine d acc ns c cs - (Chunk c' cs') -> loop d acc ns c' cs' - | otherwise = - case B.unsafeHead c of - w | w >= 0x30 && w <= 0x39 -> - if d < 9 then loop (d+1) - (10*acc + (fromIntegral w - 0x30)) - ns (B.unsafeTail c) cs - else loop 1 (fromIntegral w - 0x30) - (fromIntegral acc : ns) - (B.unsafeTail c) cs - | otherwise -> combine d acc ns c cs - - combine _ acc [] c cs = end (fromIntegral acc) c cs - combine d acc ns c cs = - end (10^d * combine1 1000000000 ns + fromIntegral acc) c cs - - combine1 _ [n] = n - combine1 b ns = combine1 (b*b) $ combine2 b ns - - combine2 b (n:m:ns) = let t = n+m*b in t `seq` (t : combine2 b ns) - combine2 _ ns = ns - - end n c cs = let c' = chunk c cs - in c' `seq` (n, c') - --- | Read an entire file /lazily/ into a 'ByteString'. -readFile :: FilePath -> IO ByteString -readFile f = openFile f ReadMode >>= hGetContents - --- | Write a 'ByteString' to a file. -writeFile :: FilePath -> ByteString -> IO () -writeFile f txt = bracket (openFile f WriteMode) hClose - (\hdl -> hPut hdl txt) - --- | Append a 'ByteString' to a file. -appendFile :: FilePath -> ByteString -> IO () -appendFile f txt = bracket (openFile f AppendMode) hClose - (\hdl -> hPut hdl txt) - - --- | Write a ByteString to a handle, appending a newline byte +-- | Write a ByteString to a handle, appending a newline byte. -- +-- The chunks will be +-- written one at a time, followed by a newline. +-- Other threads might write to the 'Handle' in between, +-- and hence 'hPutStrLn' alone is not suitable for concurrent writes. +-- hPutStrLn :: Handle -> ByteString -> IO () hPutStrLn h ps = hPut h ps >> hPut h (L.singleton 0x0a) --- | Write a ByteString to stdout, appending a newline byte +-- | Write a ByteString to 'stdout', appending a newline byte. +-- +-- The chunks will be +-- written one at a time, followed by a newline. +-- Other threads might write to the 'stdout' in between, +-- and hence 'putStrLn' alone is not suitable for concurrent writes. +-- putStrLn :: ByteString -> IO () putStrLn = hPutStrLn stdout - - --- --------------------------------------------------------------------- --- Internal utilities - --- reverse a list of possibly-empty chunks into a lazy ByteString -revChunks :: [S.ByteString] -> ByteString -revChunks cs = List.foldl' (flip chunk) Empty cs diff --git a/Data/ByteString/Lazy/Internal.hs b/Data/ByteString/Lazy/Internal.hs --- a/Data/ByteString/Lazy/Internal.hs +++ b/Data/ByteString/Lazy/Internal.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-} -#if __GLASGOW_HASKELL__ -{-# LANGUAGE DeriveDataTypeable #-} -#endif -{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Unsafe #-} +{-# OPTIONS_HADDOCK not-home #-} + +{-# LANGUAGE TypeFamilies #-} + -- | -- Module : Data.ByteString.Lazy.Internal -- Copyright : (c) Don Stewart 2006-2008 @@ -12,7 +13,7 @@ -- Maintainer : dons00@gmail.com, duncan@community.haskell.org -- Stability : unstable -- Portability : non-portable --- +-- -- A module containing semi-public 'ByteString' internals. This exposes -- the 'ByteString' representation and low level construction functions. -- Modules which extend the 'ByteString' system will need to use this module @@ -22,7 +23,8 @@ module Data.ByteString.Lazy.Internal ( -- * The lazy @ByteString@ type and representation - ByteString(..), -- instances: Eq, Ord, Show, Read, Data, Typeable + ByteString(Empty, Chunk), + LazyByteString, chunk, foldrChunks, foldlChunks, @@ -39,56 +41,83 @@ -- * Conversion with lists: packing and unpacking packBytes, packChars, unpackBytes, unpackChars, + -- * Conversions with strict ByteString + fromStrict, toStrict, ) where import Prelude hiding (concat) -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString as S (length, take, drop) +import qualified Data.ByteString.Internal.Type as S -import Data.Word (Word8) +import Data.Word (Word8) import Foreign.Storable (Storable(sizeOf)) -import Data.Monoid (Monoid(..)) +import Data.Semigroup (Semigroup (..)) +import Data.List.NonEmpty (NonEmpty ((:|))) import Control.DeepSeq (NFData, rnf) -#if MIN_VERSION_base(3,0,0) import Data.String (IsString(..)) -#endif -import Data.Typeable (Typeable) -#if MIN_VERSION_base(4,1,0) -import Data.Data (Data(..)) -#if MIN_VERSION_base(4,2,0) -import Data.Data (mkNoRepType) -#else -import Data.Data (mkNorepType) -#endif -#else -import Data.Generics (Data(..), mkNorepType) +import Data.Data (Data(..), mkConstr, mkNoRepType, Constr, DataType, Fixity(Prefix), constrIndex) + +import GHC.Exts (IsList(..)) + +import qualified Language.Haskell.TH.Syntax as TH + +#ifdef HS_BYTESTRING_ASSERTIONS +import Control.Exception (assert) #endif --- | A space-efficient representation of a Word8 vector, supporting many --- efficient operations. A 'ByteString' contains 8-bit characters only. + +-- | A space-efficient representation of a 'Word8' vector, supporting many +-- efficient operations. -- --- Instances of Eq, Ord, Read, Show, Data, Typeable +-- A 'LazyByteString' contains 8-bit bytes, or by using the operations +-- from "Data.ByteString.Lazy.Char8" it can be interpreted as containing +-- 8-bit characters. -- -data ByteString = Empty | Chunk {-# UNPACK #-} !S.ByteString ByteString +#ifndef HS_BYTESTRING_ASSERTIONS +data ByteString = Empty | Chunk {-# UNPACK #-} !S.StrictByteString ByteString + -- INVARIANT: The S.StrictByteString field of any Chunk is not empty. + -- (See also the 'invariant' and 'checkInvariant' functions.) -#if defined(__GLASGOW_HASKELL__) - deriving (Typeable) + -- To make testing of this invariant convenient, we add an + -- assertion to that effect when the HS_BYTESTRING_ASSERTIONS + -- preprocessor macro is defined, by renaming the actual constructor + -- and providing a pattern synonym that does the checking: +#else +data ByteString = Empty | Chunk_ {-# UNPACK #-} !S.StrictByteString ByteString + +pattern Chunk :: S.StrictByteString -> ByteString -> ByteString +pattern Chunk c cs <- Chunk_ c cs where + Chunk c@(S.BS _ len) cs = assert (len > 0) Chunk_ c cs + +{-# COMPLETE Empty, Chunk #-} #endif +deriving instance TH.Lift ByteString + + +-- | Type synonym for the lazy flavour of 'ByteString'. +-- +-- @since 0.11.2.0 +type LazyByteString = ByteString + instance Eq ByteString where (==) = eq instance Ord ByteString where compare = cmp +instance Semigroup ByteString where + (<>) = append + sconcat (b:|bs) = concat (b:bs) + stimes = times + instance Monoid ByteString where mempty = Empty - mappend = append + mappend = (<>) mconcat = concat instance NFData ByteString where @@ -101,21 +130,31 @@ instance Read ByteString where readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ] -#if MIN_VERSION_base(3,0,0) +-- | @since 0.10.12.0 +instance IsList ByteString where + type Item ByteString = Word8 + fromList = packBytes + toList = unpackBytes + +-- | Beware: 'fromString' truncates multi-byte characters to octets. +-- e.g. "枯朶に烏のとまりけり秋の暮" becomes �6k�nh~�Q��n� instance IsString ByteString where fromString = packChars -#endif instance Data ByteString where gfoldl f z txt = z packBytes `f` unpackBytes txt - toConstr _ = error "Data.ByteString.Lazy.ByteString.toConstr" - gunfold _ _ = error "Data.ByteString.Lazy.ByteString.gunfold" -#if MIN_VERSION_base(4,2,0) - dataTypeOf _ = mkNoRepType "Data.ByteString.Lazy.ByteString" -#else - dataTypeOf _ = mkNorepType "Data.ByteString.Lazy.ByteString" -#endif + toConstr _ = packConstr + gunfold k z c = case constrIndex c of + 1 -> k (z packBytes) + _ -> error "gunfold: unexpected constructor of lazy ByteString" + dataTypeOf _ = byteStringDataType +packConstr :: Constr +packConstr = mkConstr byteStringDataType "pack" [] Prefix + +byteStringDataType :: DataType +byteStringDataType = mkNoRepType "Data.ByteString.Lazy.ByteString" + ------------------------------------------------------------------------ -- Packing and unpacking from lists @@ -128,8 +167,7 @@ (bs, cs') -> Chunk bs (packChunks (min (n * 2) smallChunkSize) cs') packChars :: [Char] -> ByteString -packChars cs0 = - packChunks 32 cs0 +packChars cs0 = packChunks 32 cs0 where packChunks n cs = case S.packUptoLenChars n cs of (bs, []) -> chunk bs Empty @@ -145,18 +183,24 @@ ------------------------------------------------------------------------ +-- We no longer use these invariant-checking functions internally, +-- preferring an assertion on `Chunk` itself, controlled by the +-- HS_BYTESTRING_ASSERTIONS preprocessor macro. + -- | The data type invariant: --- Every ByteString is either 'Empty' or consists of non-null 'S.ByteString's. --- All functions must preserve this, and the QC properties must check this. +-- Every ByteString is either 'Empty' or consists of non-null +-- 'S.StrictByteString's. All functions must preserve this. -- invariant :: ByteString -> Bool invariant Empty = True -invariant (Chunk (S.PS _ _ len) cs) = len > 0 && invariant cs +invariant (Chunk (S.BS _ len) cs) = len > 0 && invariant cs --- | In a form that checks the invariant lazily. +-- | Lazily checks that the given 'ByteString' satisfies the data type's +-- "no empty chunks" invariant, raising an exception in place of the +-- first chunk that does not satisfy the invariant. checkInvariant :: ByteString -> ByteString checkInvariant Empty = Empty -checkInvariant (Chunk c@(S.PS _ _ len) cs) +checkInvariant (Chunk c@(S.BS _ len) cs) | len > 0 = Chunk c (checkInvariant cs) | otherwise = error $ "Data.ByteString.Lazy: invariant violation:" ++ show (Chunk c cs) @@ -164,13 +208,13 @@ ------------------------------------------------------------------------ -- | Smart constructor for 'Chunk'. Guarantees the data type invariant. -chunk :: S.ByteString -> ByteString -> ByteString -chunk c@(S.PS _ _ len) cs | len == 0 = cs - | otherwise = Chunk c cs +chunk :: S.StrictByteString -> ByteString -> ByteString +chunk c@(S.BS _ len) cs | len == 0 = cs + | otherwise = Chunk c cs {-# INLINE chunk #-} -- | Consume the chunks of a lazy ByteString with a natural right fold. -foldrChunks :: (S.ByteString -> a -> a) -> a -> ByteString -> a +foldrChunks :: (S.StrictByteString -> a -> a) -> a -> ByteString -> a foldrChunks f z = go where go Empty = z go (Chunk c cs) = f c (go cs) @@ -178,11 +222,10 @@ -- | Consume the chunks of a lazy ByteString with a strict, tail-recursive, -- accumulating left fold. -foldlChunks :: (a -> S.ByteString -> a) -> a -> ByteString -> a -foldlChunks f z = go z - where go a _ | a `seq` False = undefined - go a Empty = a - go a (Chunk c cs) = go (f a c) cs +foldlChunks :: (a -> S.StrictByteString -> a) -> a -> ByteString -> a +foldlChunks f = go + where go !a Empty = a + go !a (Chunk c cs) = go (f a c) cs {-# INLINE foldlChunks #-} ------------------------------------------------------------------------ @@ -219,35 +262,91 @@ eq Empty Empty = True eq Empty _ = False eq _ Empty = False -eq (Chunk a as) (Chunk b bs) = - case compare (S.length a) (S.length b) of - LT -> a == (S.take (S.length a) b) && eq as (Chunk (S.drop (S.length a) b) bs) - EQ -> a == b && eq as bs - GT -> (S.take (S.length b) a) == b && eq (Chunk (S.drop (S.length b) a) as) bs +eq (Chunk a@(S.BS ap al) as) (Chunk b@(S.BS bp bl) bs) = + case compare al bl of + LT -> a == S.BS bp al && eq as (Chunk (S.BS (S.plusForeignPtr bp al) (bl - al)) bs) + EQ -> a == b && eq as bs + GT -> S.BS ap bl == b && eq (Chunk (S.BS (S.plusForeignPtr ap bl) (al - bl)) as) bs cmp :: ByteString -> ByteString -> Ordering cmp Empty Empty = EQ cmp Empty _ = LT cmp _ Empty = GT -cmp (Chunk a as) (Chunk b bs) = - case compare (S.length a) (S.length b) of - LT -> case compare a (S.take (S.length a) b) of - EQ -> cmp as (Chunk (S.drop (S.length a) b) bs) +cmp (Chunk a@(S.BS ap al) as) (Chunk b@(S.BS bp bl) bs) = + case compare al bl of + LT -> case compare a (S.BS bp al) of + EQ -> cmp as (Chunk (S.BS (S.plusForeignPtr bp al) (bl - al)) bs) result -> result EQ -> case compare a b of EQ -> cmp as bs result -> result - GT -> case compare (S.take (S.length b) a) b of - EQ -> cmp (Chunk (S.drop (S.length b) a) as) bs + GT -> case compare (S.BS ap bl) b of + EQ -> cmp (Chunk (S.BS (S.plusForeignPtr ap bl) (al - bl)) as) bs result -> result append :: ByteString -> ByteString -> ByteString append xs ys = foldrChunks Chunk ys xs concat :: [ByteString] -> ByteString -concat css0 = to css0 +concat = to where go Empty css = to css go (Chunk c cs) css = Chunk c (go cs css) to [] = Empty to (cs:css) = go cs css + +-- | Repeats the given ByteString n times. +times :: Integral a => a -> ByteString -> ByteString +times 0 _ = Empty +times n lbs0 + | n < 0 = error "stimes: non-negative multiplier expected" + | otherwise = case lbs0 of + Empty -> Empty + Chunk bs lbs -> Chunk bs (go lbs) + where + go Empty = times (n-1) lbs0 + go (Chunk c cs) = Chunk c (go cs) + +------------------------------------------------------------------------ +-- Conversions + +-- |/O(1)/ Convert a 'S.StrictByteString' into a 'LazyByteString'. +fromStrict :: S.StrictByteString -> LazyByteString +fromStrict (S.BS _ 0) = Empty +fromStrict bs = Chunk bs Empty + +-- |/O(n)/ Convert a 'LazyByteString' into a 'S.StrictByteString'. +-- +-- Note that this is an /expensive/ operation that forces the whole +-- 'LazyByteString' into memory and then copies all the data. If possible, try to +-- avoid converting back and forth between strict and lazy bytestrings. +-- +toStrict :: LazyByteString -> S.StrictByteString +toStrict = \cs -> goLen0 cs cs + -- We pass the original [ByteString] (bss0) through as an argument through + -- goLen0, goLen1, and goLen since we will need it again in goCopy. Passing + -- it as an explicit argument avoids capturing it in these functions' + -- closures which would result in unnecessary closure allocation. + where + -- It's still possible that the result is empty + goLen0 _ Empty = S.BS S.nullForeignPtr 0 + goLen0 cs0 (Chunk c cs) = goLen1 cs0 c cs + + -- It's still possible that the result is a single chunk + goLen1 _ bs Empty = bs + goLen1 cs0 (S.BS _ bl) (Chunk (S.BS _ cl) cs) = + goLen cs0 (S.checkedAdd "Lazy.toStrict" bl cl) cs + + -- General case, just find the total length we'll need + goLen cs0 !total (Chunk (S.BS _ cl) cs) = + goLen cs0 (S.checkedAdd "Lazy.toStrict" total cl) cs + goLen cs0 total Empty = + S.unsafeCreateFp total $ \ptr -> goCopy cs0 ptr + + -- Copy the data + goCopy Empty !_ = return () + goCopy (Chunk (S.BS fp len) cs) !ptr = do + S.memcpyFp ptr fp len + goCopy cs (ptr `S.plusForeignPtr` len) +-- See the comment on Data.ByteString.Internal.concat for some background on +-- this implementation. diff --git a/Data/ByteString/Lazy/ReadInt.hs b/Data/ByteString/Lazy/ReadInt.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/ReadInt.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE CPP #-} + +-- This file is also included by "Data.ByteString.ReadInt", after defining +-- "BYTESTRING_STRICT". The two modules share much of their code, but +-- the lazy version adds an outer loop over the chunks. + +#ifdef BYTESTRING_STRICT +module Data.ByteString.ReadInt +#else +module Data.ByteString.Lazy.ReadInt +#endif + ( readInt + , readInt8 + , readInt16 + , readInt32 + , readWord + , readWord8 + , readWord16 + , readWord32 + , readInt64 + , readWord64 + ) where + +import qualified Data.ByteString.Internal as BI +#ifdef BYTESTRING_STRICT +import Data.ByteString +#else +import Data.ByteString.Lazy +import Data.ByteString.Lazy.Internal +#endif +import Data.Bits (FiniteBits, isSigned) +import Data.ByteString.Internal (pattern BS, plusForeignPtr) +import Data.Int +import Data.Word +import Foreign.ForeignPtr (ForeignPtr) +import Foreign.Ptr (minusPtr, plusPtr) +import Foreign.Storable (Storable(..)) + +----- Public API + +-- | Try to read a signed 'Int' value from the 'ByteString', returning +-- @Just (val, str)@ on success, where @val@ is the value read and @str@ is the +-- rest of the input string. If the sequence of digits decodes to a value +-- larger than can be represented by an 'Int', the returned value will be +-- 'Nothing'. +-- +-- 'readInt' does not ignore leading whitespace, the value must start +-- immediately at the beginning of the input string. +-- +-- ==== __Examples__ +-- >>> readInt "-1729 sum of cubes" +-- Just (-1729," sum of cubes") +-- >>> readInt "+1: readInt also accepts a leading '+'" +-- Just (1, ": readInt also accepts a leading '+'") +-- >>> readInt "not a decimal number" +-- Nothing +-- >>> readInt "12345678901234567890 overflows maxBound" +-- Nothing +-- >>> readInt "-12345678901234567890 underflows minBound" +-- Nothing +-- +readInt :: ByteString -> Maybe (Int, ByteString) +readInt = _read + +-- | A variant of 'readInt' specialised to 'Int32'. +readInt32 :: ByteString -> Maybe (Int32, ByteString) +readInt32 = _read + +-- | A variant of 'readInt' specialised to 'Int16'. +readInt16 :: ByteString -> Maybe (Int16, ByteString) +readInt16 = _read + +-- | A variant of 'readInt' specialised to 'Int8'. +readInt8 :: ByteString -> Maybe (Int8, ByteString) +readInt8 = _read + +-- | Try to read a 'Word' value from the 'ByteString', returning +-- @Just (val, str)@ on success, where @val@ is the value read and @str@ is the +-- rest of the input string. If the sequence of digits decodes to a value +-- larger than can be represented by a 'Word', the returned value will be +-- 'Nothing'. +-- +-- 'readWord' does not ignore leading whitespace, the value must start with a +-- decimal digit immediately at the beginning of the input string. Leading @+@ +-- signs are not accepted. +-- +-- ==== __Examples__ +-- >>> readWord "1729 sum of cubes" +-- Just (1729," sum of cubes") +-- >>> readWord "+1729 has an explicit sign" +-- Nothing +-- >>> readWord "not a decimal number" +-- Nothing +-- >>> readWord "98765432109876543210 overflows maxBound" +-- Nothing +-- +readWord :: ByteString -> Maybe (Word, ByteString) +readWord = _read + +-- | A variant of 'readWord' specialised to 'Word32'. +readWord32 :: ByteString -> Maybe (Word32, ByteString) +readWord32 = _read + +-- | A variant of 'readWord' specialised to 'Word16'. +readWord16 :: ByteString -> Maybe (Word16, ByteString) +readWord16 = _read + +-- | A variant of 'readWord' specialised to 'Word8'. +readWord8 :: ByteString -> Maybe (Word8, ByteString) +readWord8 = _read + +-- | A variant of 'readInt' specialised to 'Int64'. +readInt64 :: ByteString -> Maybe (Int64, ByteString) +readInt64 = _read + +-- | A variant of 'readWord' specialised to 'Word64'. +readWord64 :: ByteString -> Maybe (Word64, ByteString) +readWord64 = _read + +-- | Polymorphic Int*/Word* reader +_read :: forall a. (Integral a, FiniteBits a, Bounded a) + => ByteString -> Maybe (a, ByteString) +{-# INLINE _read #-} +_read + | isSigned @a 0 + = \ bs -> signed bs >>= \ (r, s, d1) -> _readDecimal r s d1 + | otherwise + -- When the input is @16^n-1@, as is the case with 'maxBound' for + -- all the Word* types, the last decimal digit of 'maxBound' is 5. + = \ bs -> unsigned 5 bs >>= \ (r, s, d1) -> _readDecimal r s d1 + where + -- Returns: + -- * Mod 10 min/max bound remainder + -- * 2nd and later digits + -- * 1st digit + -- + -- When the input is @8*16^n-1@, as is the case with 'maxBound' for + -- all the Int* types, the last decimal digit of 'maxBound' is 7. + -- + signed :: ByteString -> Maybe (Word64, ByteString, Word64) + signed bs = do + (w, s) <- uncons bs + let d1 = fromDigit w + if | d1 <= 9 -> Just (7, s, d1) -- leading digit + | w == 0x2d -> unsigned 8 s -- minus sign + | w == 0x2b -> unsigned 7 s -- plus sign + | otherwise -> Nothing -- not a number + + unsigned :: Word64 -> ByteString -> Maybe (Word64, ByteString, Word64) + unsigned r bs = do + (w, s) <- uncons bs + let d1 = fromDigit w + if | d1 <= 9 -> Just (r, s, d1) -- leading digit + | otherwise -> Nothing -- not a number + +----- Fixed-width unsigned reader + +-- | Intermediate result from scanning a chunk, final output is +-- converted to the requested type once all chunks are processed. +-- +data Result = Overflow + | Result !Int -- number of bytes (digits) read + !Word64 -- accumulator value + +_readDecimal :: forall a. (Integral a, Bounded a) + => Word64 -- ^ abs(maxBound/minBound) `mod` 10 + -> ByteString -- ^ Input string + -> Word64 -- ^ First digit value + -> Maybe (a, ByteString) +{-# INLINE _readDecimal #-} +_readDecimal !r = consume + where + consume :: ByteString -> Word64 -> Maybe (a, ByteString) +#ifdef BYTESTRING_STRICT + consume (BS fp len) a = case _digits q r fp len a of + Result used acc + | used == len + -> convert acc empty + | otherwise + -> convert acc $ BS (fp `plusForeignPtr` used) (len - used) + _ -> Nothing +#else + -- All done + consume Empty acc = convert acc Empty + -- Process next chunk + consume (Chunk (BS fp len) cs) acc + = case _digits q r fp len acc of + Result used acc' + | used == len + -- process remaining chunks + -> consume cs acc' + | otherwise + -- ran into a non-digit + -> convert acc' $ + Chunk (BS (fp `plusForeignPtr` used) (len - used)) cs + _ -> Nothing +#endif + convert :: Word64 -> ByteString -> Maybe (a, ByteString) + convert !acc rest = + let !i = case r of + -- minBound @Int* `mod` 10 == 8 + 8 -> negate $ fromIntegral @Word64 @a acc + _ -> fromIntegral @Word64 @a acc + in Just (i, rest) + + -- The quotient of 'maxBound' divided by 10 is needed for + -- overflow checks, once the accumulator exceeds this value + -- no further digits can be added. If equal, the last digit + -- must not exceed the `r` value (max/min bound `mod` 10). + -- + q = fromIntegral @a @Word64 maxBound `div` 10 + +----- Per chunk decoder + +-- | Process as many digits as we can, returning the additional +-- number of digits found and the updated accumulator. If the +-- accumulator would overflow return 'Overflow'. +-- +_digits :: Word64 -- ^ maximum non-overflow value `div` 10 + -> Word64 -- ^ maximum non-overflow vavlue `mod` 10 + -> ForeignPtr Word8 -- ^ Input buffer + -> Int -- ^ Input length + -> Word64 -- ^ Accumulated value of leading digits + -> Result -- ^ Bytes read and final accumulator, + -- or else overflow indication +{-# INLINE _digits #-} +_digits !q !r fp len a = BI.accursedUnutterablePerformIO $ + BI.unsafeWithForeignPtr fp $ \ ptr -> do + let end = ptr `plusPtr` len + go ptr end ptr a + where + go !start !end = loop + where + loop !ptr !acc = getDigit >>= \ !d -> + if | d > 9 + -> return $ Result (ptr `minusPtr` start) acc + | acc < q || acc == q && d <= r + -> loop (ptr `plusPtr` 1) (acc * 10 + d) + | otherwise + -> return Overflow + where + getDigit :: IO Word64 + getDigit + | ptr /= end = fromDigit <$> peek ptr + | otherwise = pure 10 -- End of input + {-# NOINLINE getDigit #-} + -- 'getDigit' makes it possible to implement a single success + -- exit point from the loop. If instead we return 'Result' + -- from multiple places, when '_digits' is inlined we get (at + -- least GHC 8.10 through 9.2) for each exit path a separate + -- join point implementing the continuation code. GHC ticket + -- . + -- + -- The NOINLINE pragma is required to avoid inlining branches + -- that would restore multiple exit points. + +fromDigit :: Word8 -> Word64 +{-# INLINE fromDigit #-} +fromDigit = \ !w -> fromIntegral w - 0x30 -- i.e. w - '0' diff --git a/Data/ByteString/Lazy/ReadNat.hs b/Data/ByteString/Lazy/ReadNat.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/ReadNat.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE CPP #-} + +-- This file is included by "Data.ByteString.ReadInt", after defining +-- "BYTESTRING_STRICT". The two modules are largely identical, except for the +-- choice of ByteString type and the loops in `readNatural`, where the lazy +-- version needs to nest the inner loop inside a loop over the constituent +-- chunks. + +#ifdef BYTESTRING_STRICT +module Data.ByteString.ReadNat +#else +module Data.ByteString.Lazy.ReadNat +#endif + ( readInteger + , readNatural + ) where + +import qualified Data.ByteString.Internal as BI +#ifdef BYTESTRING_STRICT +import Data.ByteString +#else +import Data.ByteString.Lazy +import Data.ByteString.Lazy.Internal +#endif +import Data.Bits (finiteBitSize) +import Data.ByteString.Internal (pattern BS, plusForeignPtr) +import Data.Word +import Foreign.ForeignPtr (ForeignPtr) +import Foreign.Ptr (Ptr, minusPtr, plusPtr) +import Foreign.Storable (Storable(..)) +import Numeric.Natural (Natural) + +----- Public API + +-- | 'readInteger' reads an 'Integer' from the beginning of the 'ByteString'. +-- If there is no 'Integer' at the beginning of the string, it returns +-- 'Nothing', otherwise it just returns the 'Integer' read, and the rest of +-- the string. +-- +-- 'readInteger' does not ignore leading whitespace, the value must start +-- immediately at the beginning of the input string. +-- +-- ==== __Examples__ +-- >>> readInteger "-000111222333444555666777888999 all done" +-- Just (-111222333444555666777888999," all done") +-- >>> readInteger "+1: readInteger also accepts a leading '+'" +-- Just (1, ": readInteger also accepts a leading '+'") +-- >>> readInteger "not a decimal number" +-- Nothing +-- +readInteger :: ByteString -> Maybe (Integer, ByteString) +readInteger = \ bs -> do + (w, s) <- uncons bs + let d = fromDigit w + if | d <= 9 -> unsigned d s -- leading digit + | w == 0x2d -> negative s -- minus sign + | w == 0x2b -> positive s -- plus sign + | otherwise -> Nothing -- not a number + where + unsigned :: Word -> ByteString -> Maybe (Integer, ByteString) + unsigned d s = + let (!n, rest) = _readDecimal d s + !i = toInteger n + in Just (i, rest) + + positive :: ByteString -> Maybe (Integer, ByteString) + positive bs = do + (w, s) <- uncons bs + let d = fromDigit w + if | d <= 9 -> unsigned d s + | otherwise -> Nothing + + negative :: ByteString -> Maybe (Integer, ByteString) + negative bs = do + (w, s) <- uncons bs + let d = fromDigit w + if | d > 9 -> Nothing + | otherwise -> let (n, rest) = _readDecimal d s + !i = negate $ toInteger n + in Just (i, rest) + +-- | 'readNatural' reads a 'Natural' number from the beginning of the +-- 'ByteString'. If there is no 'Natural' number at the beginning of the +-- string, it returns 'Nothing', otherwise it just returns the number read, and +-- the rest of the string. +-- +-- 'readNatural' does not ignore leading whitespace, the value must start with +-- a decimal digit immediately at the beginning of the input string. Leading +-- @+@ signs are not accepted. +-- +-- ==== __Examples__ +-- >>> readNatural "000111222333444555666777888999 all done" +-- Just (111222333444555666777888999," all done") +-- >>> readNatural "+000111222333444555666777888999 explicit sign" +-- Nothing +-- >>> readNatural "not a decimal number" +-- Nothing +-- +readNatural :: ByteString -> Maybe (Natural, ByteString) +readNatural bs = do + (w, s) <- uncons bs + let d = fromDigit w + if | d <= 9 -> Just $! _readDecimal d s + | otherwise -> Nothing + +----- Internal implementation + +-- | Intermediate result from scanning a chunk, final output is +-- obtained via `convert` after all the chunks are processed. +-- +data Result = Result !Int -- Bytes consumed + !Word -- Value of LSW + !Int -- Digits in LSW + [Natural] -- Little endian MSW list + +_readDecimal :: Word -> ByteString -> (Natural, ByteString) +_readDecimal = + -- Having read one digit, we're about to read the 2nd So the digit count + -- up to 'safeLog' starts at 2. + consume [] 2 + where + consume :: [Natural] -> Int -> Word -> ByteString + -> (Natural, ByteString) +#ifdef BYTESTRING_STRICT + consume ns cnt acc (BS fp len) = + -- Having read one digit, we're about to read the 2nd + -- So the digit count up to 'safeLog' starts at 2. + case natdigits fp len acc cnt ns of + Result used acc' cnt' ns' + | used == len + -> convert acc' cnt' ns' $ empty + | otherwise + -> convert acc' cnt' ns' $ + BS (fp `plusForeignPtr` used) (len - used) +#else + -- All done + consume ns cnt acc Empty = convert acc cnt ns Empty + -- Process next chunk + consume ns cnt acc (Chunk (BS fp len) cs) + = case natdigits fp len acc cnt ns of + Result used acc' cnt' ns' + | used == len -- process more chunks + -> consume ns' cnt' acc' cs + | otherwise -- ran into a non-digit + -> let c = Chunk (BS (fp `plusForeignPtr` used) (len - used)) cs + in convert acc' cnt' ns' c +#endif + convert !acc !cnt !ns rest = + let !n = combine acc cnt ns + in (n, rest) + + -- | Merge least-significant word with reduction of of little-endian tail. + -- + -- The input is: + -- + -- * Least significant digits as a 'Word' (LSW) + -- * The number of digits that went into the LSW + -- * All the remaining digit groups ('safeLog' digits each), + -- in little-endian order + -- + -- The result is obtained by pairwise recursive combining of all the + -- full size digit groups, followed by multiplication by @10^cnt@ and + -- addition of the LSW. + combine :: Word -- ^ value of LSW + -> Int -- ^ count of digits in LSW + -> [Natural] -- ^ tail elements (base @10^'safeLog'@) + -> Natural + {-# INLINE combine #-} + combine !acc !_ [] = wordToNatural acc + combine !acc !cnt ns = + wordToNatural (10^cnt) * combine1 safeBase ns + wordToNatural acc + + -- | Recursive reduction of little-endian sequence of 'Natural'-valued + -- /digits/ in base @base@ (a power of 10). The base is squared after + -- each round. This shows better asymptotic performance than one word + -- at a time multiply-add folds. See: + -- + -- + combine1 :: Natural -> [Natural] -> Natural + combine1 _ [n] = n + combine1 base ns = combine1 (base * base) (combine2 base ns) + + -- | One round pairwise merge of numbers in base @base@. + combine2 :: Natural -> [Natural] -> [Natural] + combine2 base (n:m:ns) = let !t = m * base + n in t : combine2 base ns + combine2 _ ns = ns + +-- The intermediate representation is a little-endian sequence in base +-- @10^'safeLog'@, prefixed by an initial element in base @10^cnt@ for some +-- @cnt@ between 1 and 'safeLog'. The final result is obtained by recursive +-- pairwise merging of the tail followed by a final multiplication by @10^cnt@ +-- and addition of the head. +-- +natdigits :: ForeignPtr Word8 -- ^ Input chunk + -> Int -- ^ Chunk length + -> Word -- ^ accumulated element + -> Int -- ^ partial digit count + -> [Natural] -- ^ accumulated MSB elements + -> Result +{-# INLINE natdigits #-} +natdigits fp len = \ acc cnt ns -> + BI.accursedUnutterablePerformIO $ + BI.unsafeWithForeignPtr fp $ \ ptr -> do + let end = ptr `plusPtr` len + go ptr end acc cnt ns ptr + where + go !start !end = loop + where + loop :: Word -> Int -> [Natural] -> Ptr Word8 -> IO Result + loop !acc !cnt ns !ptr = getDigit >>= \ !d -> + if | d > 9 + -> return $ Result (ptr `minusPtr` start) acc cnt ns + | cnt < safeLog + -> loop (10*acc + d) (cnt+1) ns $ ptr `plusPtr` 1 + | otherwise + -> let !acc' = wordToNatural acc + in loop d 1 (acc' : ns) $ ptr `plusPtr` 1 + where + getDigit | ptr /= end = fromDigit <$> peek ptr + | otherwise = pure 10 -- End of input + {-# NOINLINE getDigit #-} + -- 'getDigit' makes it possible to implement a single success + -- exit point from the loop. If instead we return 'Result' + -- from multiple places, when 'natdigits' is inlined we get (at + -- least GHC 8.10 through 9.2) for each exit path a separate + -- join point implementing the continuation code. GHC ticket + -- . + -- + -- The NOINLINE pragma is required to avoid inlining branches + -- that would restore multiple exit points. + +----- Misc functions + +-- | Largest decimal digit count that never overflows the accumulator +-- The base 10 logarithm of 2 is ~0.30103, therefore 2^n has at least +-- @1 + floor (0.3 n)@ decimal digits. Therefore @floor (0.3 n)@, +-- digits cannot overflow the upper bound of an @n-bit@ word. +-- +safeLog :: Int +safeLog = 3 * finiteBitSize @Word 0 `div` 10 + +-- | 10-power base for little-endian sequence of ~Word-sized "digits" +safeBase :: Natural +safeBase = 10 ^ safeLog + +fromDigit :: Word8 -> Word +{-# INLINE fromDigit #-} +fromDigit = \ !w -> fromIntegral w - 0x30 -- i.e. w - '0' + +wordToNatural :: Word -> Natural +{-# INLINE wordToNatural #-} +wordToNatural = fromIntegral diff --git a/Data/ByteString/ReadInt.hs b/Data/ByteString/ReadInt.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/ReadInt.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE CPP #-} +#define BYTESTRING_STRICT +#include "Lazy/ReadInt.hs" diff --git a/Data/ByteString/ReadNat.hs b/Data/ByteString/ReadNat.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/ReadNat.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE CPP #-} +#define BYTESTRING_STRICT +#include "Lazy/ReadNat.hs" diff --git a/Data/ByteString/Short.hs b/Data/ByteString/Short.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Short.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Data.ByteString.Short +-- Copyright : (c) Duncan Coutts 2012-2013, Julian Ospald 2022 +-- License : BSD-style +-- +-- Maintainer : hasufell@posteo.de +-- Stability : stable +-- Portability : ghc only +-- +-- A compact representation suitable for storing short byte strings in memory. +-- +-- In typical use cases it can be imported alongside "Data.ByteString", e.g. +-- +-- > import qualified Data.ByteString as B +-- > import qualified Data.ByteString.Short as B +-- > (ShortByteString, toShort, fromShort) +-- +-- Other 'ShortByteString' operations clash with "Data.ByteString" or "Prelude" +-- functions however, so they should be imported @qualified@ with a different +-- alias e.g. +-- +-- > import qualified Data.ByteString.Short as B.Short +-- +module Data.ByteString.Short ( + + -- * The @ShortByteString@ type + + ShortByteString(..), + + -- ** Memory overhead + -- | With GHC, the memory overheads are as follows, expressed in words and + -- in bytes (words are 4 and 8 bytes on 32 or 64bit machines respectively). + -- + -- * t'Data.ByteString.ByteString' unshared: 8 words; 32 or 64 bytes. + -- + -- * t'Data.ByteString.ByteString' shared substring: 4 words; 16 or 32 bytes. + -- + -- * 'ShortByteString': 4 words; 16 or 32 bytes. + -- + -- For the string data itself, both 'ShortByteString' and t'Data.ByteString.ByteString' use + -- one byte per element, rounded up to the nearest word. For example, + -- including the overheads, a length 10 'ShortByteString' would take + -- @16 + 12 = 28@ bytes on a 32bit platform and @32 + 16 = 48@ bytes on a + -- 64bit platform. + -- + -- These overheads can all be reduced by 1 word (4 or 8 bytes) when the + -- 'ShortByteString' or t'Data.ByteString.ByteString' is unpacked into another constructor. + -- + -- For example: + -- + -- > data ThingId = ThingId {-# UNPACK #-} !Int + -- > {-# UNPACK #-} !ShortByteString + -- + -- This will take @1 + 1 + 3@ words (the @ThingId@ constructor + + -- unpacked @Int@ + unpacked @ShortByteString@), plus the words for the + -- string data. + + -- ** Heap fragmentation + -- | With GHC, the t'Data.ByteString.ByteString' representation uses /pinned/ memory, + -- meaning it cannot be moved by the GC. This is usually the right thing to + -- do for larger strings, but for small strings using pinned memory can + -- lead to heap fragmentation which wastes space. The 'ShortByteString' + -- type (and the @Text@ type from the @text@ package) use /unpinned/ memory + -- so they do not contribute to heap fragmentation. In addition, with GHC, + -- small unpinned strings are allocated in the same way as normal heap + -- allocations, rather than in a separate pinned area. + + -- * Introducing and eliminating 'ShortByteString's + empty, + singleton, + pack, + unpack, + fromShort, + toShort, + + -- * Basic interface + snoc, + cons, + append, + last, + tail, + uncons, + head, + init, + unsnoc, + null, + length, + + -- * Encoding validation + isValidUtf8, + + -- * Transforming ShortByteStrings + map, + reverse, + intercalate, + + -- * Reducing 'ShortByteString's (folds) + foldl, + foldl', + foldl1, + foldl1', + + foldr, + foldr', + foldr1, + foldr1', + + -- ** Special folds + all, + any, + concat, + + -- ** Generating and unfolding ByteStrings + replicate, + unfoldr, + unfoldrN, + + -- * Substrings + + -- ** Breaking strings + take, + takeEnd, + takeWhileEnd, + takeWhile, + drop, + dropEnd, + dropWhile, + dropWhileEnd, + breakEnd, + break, + span, + spanEnd, + splitAt, + split, + splitWith, + stripSuffix, + stripPrefix, + + -- * Predicates + isInfixOf, + isPrefixOf, + isSuffixOf, + + -- ** Search for arbitrary substrings + breakSubstring, + + -- * Searching ShortByteStrings + + -- ** Searching by equality + elem, + + -- ** Searching with a predicate + find, + filter, + partition, + + -- * Indexing ShortByteStrings + index, + indexMaybe, + (!?), + elemIndex, + elemIndices, + count, + findIndex, + findIndices, + + -- * Low level conversions + -- ** Packing 'Foreign.C.String.CString's and pointers + packCString, + packCStringLen, + + -- ** Using ShortByteStrings as 'Foreign.C.String.CString's + useAsCString, + useAsCStringLen, + ) where + +import Data.ByteString.Short.Internal +import Prelude () + diff --git a/Data/ByteString/Short/Internal.hs b/Data/ByteString/Short/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Short/Internal.hs @@ -0,0 +1,1777 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Unsafe #-} + +{-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnliftedFFITypes #-} + +#include "bytestring-cpp-macros.h" + +-- | +-- Module : Data.ByteString.Short.Internal +-- Copyright : (c) Duncan Coutts 2012-2013, Julian Ospald 2022 +-- License : BSD-style +-- +-- Maintainer : hasufell@posteo.de +-- Stability : stable +-- Portability : ghc only +-- +-- Internal representation of ShortByteString +-- +module Data.ByteString.Short.Internal ( + + -- * The @ShortByteString@ type and representation + ShortByteString(.., SBS), + + -- * Introducing and eliminating 'ShortByteString's + empty, + singleton, + pack, + unpack, + fromShort, + toShort, + + -- * Basic interface + snoc, + cons, + append, + last, + tail, + uncons, + head, + init, + unsnoc, + null, + length, + + -- * Transforming ShortByteStrings + map, + reverse, + intercalate, + + -- * Reducing 'ShortByteString's (folds) + foldl, + foldl', + foldl1, + foldl1', + + foldr, + foldr', + foldr1, + foldr1', + + -- ** Special folds + all, + any, + concat, + + -- ** Generating and unfolding ShortByteStrings + replicate, + unfoldr, + unfoldrN, + + -- * Substrings + + -- ** Breaking strings + take, + takeEnd, + takeWhileEnd, + takeWhile, + drop, + dropEnd, + dropWhile, + dropWhileEnd, + breakEnd, + break, + span, + spanEnd, + splitAt, + split, + splitWith, + stripSuffix, + stripPrefix, + + -- * Predicates + isInfixOf, + isPrefixOf, + isSuffixOf, + + -- ** Search for arbitrary substrings + breakSubstring, + + -- * Searching ShortByteStrings + + -- ** Searching by equality + elem, + + -- ** Searching with a predicate + find, + filter, + partition, + + -- * Indexing ShortByteStrings + index, + indexMaybe, + (!?), + elemIndex, + elemIndices, + count, + findIndex, + findIndices, + unsafeIndex, + + -- * Low level operations + createFromPtr, + copyToPtr, + + -- ** Encoding validation + isValidUtf8, + + -- * Low level conversions + -- ** Packing 'Foreign.C.String.CString's and pointers + packCString, + packCStringLen, + + -- ** Using ShortByteStrings as 'Foreign.C.String.CString's + useAsCString, + useAsCStringLen, + ) where + +import Data.ByteString.Internal.Type + ( ByteString(..) + , unsafeDupablePerformIO + , accursedUnutterablePerformIO + , checkedAdd + , c_elem_index + , cIsValidUtf8BASafe + , cIsValidUtf8BA + ) + +import Data.Array.Byte + ( ByteArray(..), MutableByteArray(..) ) +import Data.Bits + ( FiniteBits (finiteBitSize) + , shiftL +#if HS_UNALIGNED_ByteArray_OPS_OK + , shiftR +#endif + , (.&.) + , (.|.) + ) +import Data.Data + ( Data(..) ) +import Data.Monoid + ( Monoid(..) ) +import Data.Semigroup + ( Semigroup(..), stimesMonoid ) +import Data.List.NonEmpty + ( NonEmpty(..) ) +import Data.String + ( IsString(..) ) +import Control.Applicative + ( pure ) +import Control.DeepSeq + ( NFData ) +import Control.Exception + ( assert ) +import Control.Monad + ( (>>) ) +import Foreign.C.String + ( CString + , CStringLen + ) +import Foreign.Marshal.Alloc + ( allocaBytes ) +import Foreign.Storable + ( pokeByteOff ) +import GHC.Exts + ( Int(I#), Int#, Ptr(Ptr), Addr#, Char(C#) + , State#, RealWorld + , ByteArray#, MutableByteArray# + , newByteArray# + , byteArrayContents# + , unsafeCoerce# + , copyMutableByteArray# + , isByteArrayPinned# + , isTrue# + , compareByteArrays# + , sizeofByteArray# + , indexWord8Array#, indexCharArray# + , writeWord8Array# + , unsafeFreezeByteArray# +#if HS_UNALIGNED_ByteArray_OPS_OK + ,writeWord64Array# + ,indexWord8ArrayAsWord64# +#endif + , setByteArray# + , sizeofByteArray# + , indexWord8Array#, indexCharArray# + , writeWord8Array# + , unsafeFreezeByteArray# + , touch# ) +import GHC.Generics + ( Generic ) +import GHC.IO hiding ( unsafeDupablePerformIO ) +import GHC.ForeignPtr + ( ForeignPtr(ForeignPtr) + , ForeignPtrContents(PlainPtr) + ) +import GHC.ST + ( ST(ST) + , runST + ) +import GHC.Stack.Types + ( HasCallStack ) +import GHC.Word +import Prelude + ( Eq(..), Ord(..), Ordering(..), Read(..), Show(..) + , ($), ($!), error, (++), (.), (||) + , String, userError + , Bool(..), (&&), otherwise + , (+), (-), fromIntegral + , (*) + , (^) + , (<$>) + , return + , Maybe(..) + , not + , snd + ) + +import qualified Data.ByteString.Internal.Type as BS + +import qualified Data.List as List +import qualified GHC.Exts +import qualified Language.Haskell.TH.Syntax as TH + +-- | A compact representation of a 'Word8' vector. +-- +-- It has a lower memory overhead than a 'ByteString' and does not +-- contribute to heap fragmentation. It can be converted to or from a +-- 'ByteString' (at the cost of copying the string data). It supports very few +-- other operations. +-- +newtype ShortByteString = + -- | @since 0.12.0.0 + ShortByteString + { unShortByteString :: ByteArray + -- ^ @since 0.12.0.0 + } + deriving (Eq, TH.Lift, Data, Generic, NFData) + +-- | Prior to @bytestring-0.12@ 'SBS' was a genuine constructor of 'ShortByteString', +-- but now it is a bundled pattern synonym, provided as a compatibility shim. +pattern SBS :: ByteArray# -> ShortByteString +pattern SBS x = ShortByteString (ByteArray x) +{-# COMPLETE SBS #-} + +-- | Lexicographic order. +instance Ord ShortByteString where + compare = compareBytes + +-- Instead of deriving Semigroup / Monoid , we stick to our own implementations +-- of mappend / mconcat, because they are safer with regards to overflows +-- (see prop_32bitOverflow_Short_mconcat test). +-- ByteArray is likely to catch up starting from GHC 9.6: +-- * https://gitlab.haskell.org/ghc/ghc/-/merge_requests/8272 +-- * https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9128 + +instance Semigroup ShortByteString where + (<>) = append + sconcat (b:|bs) = concat (b:bs) + stimes = stimesMonoid + +instance Monoid ShortByteString where + mempty = empty + mappend = (<>) + mconcat = concat + +instance Show ShortByteString where + showsPrec p ps r = showsPrec p (unpackChars ps) r + +instance Read ShortByteString where + readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ] + +-- | @since 0.10.12.0 +instance GHC.Exts.IsList ShortByteString where + type Item ShortByteString = Word8 + fromList = ShortByteString . GHC.Exts.fromList + fromListN = (ShortByteString .) . GHC.Exts.fromListN + toList = GHC.Exts.toList . unShortByteString + +-- | Beware: 'fromString' truncates multi-byte characters to octets. +-- e.g. "枯朶に烏のとまりけり秋の暮" becomes �6k�nh~�Q��n� +instance IsString ShortByteString where + fromString = packChars + +------------------------------------------------------------------------ +-- Simple operations + +-- | /O(1)/. The empty 'ShortByteString'. +empty :: ShortByteString +empty = create 0 (\_ -> return ()) + +-- | /O(1)/ The length of a 'ShortByteString'. +length :: ShortByteString -> Int +length (SBS barr#) = I# (sizeofByteArray# barr#) + +-- | /O(1)/ Test whether a 'ShortByteString' is empty. +null :: ShortByteString -> Bool +null sbs = length sbs == 0 + +-- | /O(1)/ 'ShortByteString' index (subscript) operator, starting from 0. +-- +-- This is a partial function, consider using 'indexMaybe' instead. +index :: HasCallStack => ShortByteString -> Int -> Word8 +index sbs i + | i >= 0 && i < length sbs = unsafeIndex sbs i + | otherwise = indexError sbs i + +-- | /O(1)/ 'ShortByteString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 0.11.0.0 +indexMaybe :: ShortByteString -> Int -> Maybe Word8 +indexMaybe sbs i + | i >= 0 && i < length sbs = Just $! unsafeIndex sbs i + | otherwise = Nothing +{-# INLINE indexMaybe #-} + +-- | /O(1)/ 'ShortByteString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 0.11.0.0 +(!?) :: ShortByteString -> Int -> Maybe Word8 +(!?) = indexMaybe +{-# INLINE (!?) #-} + +-- | /O(1)/ Unsafe indexing without bounds checking. +unsafeIndex :: ShortByteString -> Int -> Word8 +unsafeIndex sbs = indexWord8Array (asBA sbs) + +indexError :: HasCallStack => ShortByteString -> Int -> a +indexError sbs i = + moduleError "index" $ "error in array index: " ++ show i + ++ " not in range [0.." ++ show (length sbs) ++ "]" + +------------------------------------------------------------------------ +-- Internal utils + +asBA :: ShortByteString -> ByteArray +asBA (ShortByteString ba) = ba + +create :: Int -> (forall s. MutableByteArray s -> ST s ()) -> ShortByteString +create len fill = + assert (len >= 0) $ runST $ do + mba <- newByteArray len + fill mba + ShortByteString <$> unsafeFreezeByteArray mba +{-# INLINE create #-} + +-- | Given the maximum size needed and a function to make the contents +-- of a ShortByteString, createAndTrim makes the 'ShortByteString'. +-- The generating function is required to return the actual final size +-- (<= the maximum size) and the result value. The resulting byte array +-- is realloced to this size. +createAndTrim :: Int -> (forall s. MutableByteArray s -> ST s (Int, a)) -> (ShortByteString, a) +createAndTrim maxLen fill = + assert (maxLen >= 0) $ runST $ do + mba <- newByteArray maxLen + (len, res) <- fill mba + if assert (0 <= len && len <= maxLen) $ len >= maxLen + then do + ba <- unsafeFreezeByteArray mba + return (ShortByteString ba, res) + else do + mba2 <- newByteArray len + copyMutableByteArray mba 0 mba2 0 len + ba <- unsafeFreezeByteArray mba2 + return (ShortByteString ba, res) +{-# INLINE createAndTrim #-} + +createAndTrim' :: Int -> (forall s. MutableByteArray s -> ST s Int) -> ShortByteString +createAndTrim' maxLen fill = + assert (maxLen >= 0) $ runST $ do + mba <- newByteArray maxLen + len <- fill mba + if assert (0 <= len && len <= maxLen) $ len >= maxLen + then do + ShortByteString <$> unsafeFreezeByteArray mba + else do + mba2 <- newByteArray len + copyMutableByteArray mba 0 mba2 0 len + ShortByteString <$> unsafeFreezeByteArray mba2 +{-# INLINE createAndTrim' #-} + +-- | Like createAndTrim, but with two buffers at once +createAndTrim2 :: Int -> Int -> (forall s. MutableByteArray s -> MutableByteArray s -> ST s (Int, Int)) -> (ShortByteString, ShortByteString) +createAndTrim2 maxLen1 maxLen2 fill = + runST $ do + mba1 <- newByteArray maxLen1 + mba2 <- newByteArray maxLen2 + (len1, len2) <- fill mba1 mba2 + sbs1 <- freeze' len1 maxLen1 mba1 + sbs2 <- freeze' len2 maxLen2 mba2 + pure (sbs1, sbs2) + where + freeze' :: Int -> Int -> MutableByteArray s -> ST s ShortByteString + freeze' len maxLen mba = + if assert (0 <= len && len <= maxLen) $ len >= maxLen + then do + ShortByteString <$> unsafeFreezeByteArray mba + else do + mba2 <- newByteArray len + copyMutableByteArray mba 0 mba2 0 len + ShortByteString <$> unsafeFreezeByteArray mba2 +{-# INLINE createAndTrim2 #-} + +isPinned :: ByteArray# -> Bool +isPinned ba# = isTrue# (isByteArrayPinned# ba#) + +------------------------------------------------------------------------ +-- Conversion to and from ByteString + +-- | /O(n)/. Convert a 'ByteString' into a 'ShortByteString'. +-- +-- This makes a copy, so does not retain the input string. +-- +toShort :: ByteString -> ShortByteString +toShort !bs = unsafeDupablePerformIO (toShortIO bs) + +toShortIO :: ByteString -> IO ShortByteString +toShortIO (BS fptr len) = do + mba <- stToIO (newByteArray len) + BS.unsafeWithForeignPtr fptr $ \ptr -> + stToIO (copyAddrToByteArray ptr mba 0 len) + ShortByteString <$> stToIO (unsafeFreezeByteArray mba) + +-- | /O(n)/. Convert a 'ShortByteString' into a 'ByteString'. +-- +fromShort :: ShortByteString -> ByteString +fromShort sbs@(SBS b#) + | isPinned b# = BS inPlaceFp len + | otherwise = BS.unsafeCreateFp len $ \fp -> + BS.unsafeWithForeignPtr fp $ \p -> copyToPtr sbs 0 p len + where + inPlaceFp = ForeignPtr (byteArrayContents# b#) + (PlainPtr (unsafeCoerce# b#)) + len = I# (sizeofByteArray# b#) + +-- | /O(1)/ Convert a 'Word8' into a 'ShortByteString' +-- +-- @since 0.11.3.0 +singleton :: Word8 -> ShortByteString +singleton = \w -> create 1 (\mba -> writeWord8Array mba 0 w) + +------------------------------------------------------------------------ +-- Packing and unpacking from lists + +-- | /O(n)/. Convert a list into a 'ShortByteString' +pack :: [Word8] -> ShortByteString +pack = packBytes + +-- | /O(n)/. Convert a 'ShortByteString' into a list. +unpack :: ShortByteString -> [Word8] +unpack sbs = GHC.Exts.build (unpackFoldr sbs) +{-# INLINE unpack #-} + +-- +-- Have unpack fuse with good list consumers +-- +unpackFoldr :: ShortByteString -> (Word8 -> a -> a) -> a -> a +unpackFoldr sbs k z = foldr k z sbs +{-# INLINE [0] unpackFoldr #-} + +{-# RULES +"ShortByteString unpack-list" [1] forall bs . + unpackFoldr bs (:) [] = unpackBytes bs + #-} + +packChars :: [Char] -> ShortByteString +packChars = \cs -> packLenBytes (List.length cs) (List.map BS.c2w cs) + +packBytes :: [Word8] -> ShortByteString +packBytes = \ws -> packLenBytes (List.length ws) ws + +packLenBytes :: Int -> [Word8] -> ShortByteString +packLenBytes len ws0 = + create len (\mba -> go mba 0 ws0) + where + go :: MutableByteArray s -> Int -> [Word8] -> ST s () + go !_ !_ [] = return () + go !mba !i (w:ws) = do + writeWord8Array mba i w + go mba (i+1) ws + +-- Unpacking bytestrings into lists efficiently is a tradeoff: on the one hand +-- we would like to write a tight loop that just blats the list into memory, on +-- the other hand we want it to be unpacked lazily so we don't end up with a +-- massive list data structure in memory. +-- +-- Our strategy is to combine both: we will unpack lazily in reasonable sized +-- chunks, where each chunk is unpacked strictly. +-- +-- unpackChars does the lazy loop, while unpackAppendBytes and +-- unpackAppendChars do the chunks strictly. + +unpackChars :: ShortByteString -> [Char] +unpackChars sbs = unpackAppendCharsLazy sbs [] + +unpackBytes :: ShortByteString -> [Word8] +unpackBytes sbs = unpackAppendBytesLazy sbs [] + + +-- Why 100 bytes you ask? Because on a 64bit machine the list we allocate +-- takes just shy of 4k which seems like a reasonable amount. +-- (5 words per list element, 8 bytes per word, 100 elements = 4000 bytes) + +unpackAppendCharsLazy :: ShortByteString -> [Char] -> [Char] +unpackAppendCharsLazy sbs = go 0 (length sbs) + where + sz = 100 + + go off len cs + | len <= sz = unpackAppendCharsStrict sbs off len cs + | otherwise = unpackAppendCharsStrict sbs off sz remainder + where remainder = go (off+sz) (len-sz) cs + +unpackAppendBytesLazy :: ShortByteString -> [Word8] -> [Word8] +unpackAppendBytesLazy sbs = go 0 (length sbs) + where + sz = 100 + + go off len ws + | len <= sz = unpackAppendBytesStrict sbs off len ws + | otherwise = unpackAppendBytesStrict sbs off sz remainder + where remainder = go (off+sz) (len-sz) ws + +-- For these unpack functions, since we're unpacking the whole list strictly we +-- build up the result list in an accumulator. This means we have to build up +-- the list starting at the end. So our traversal starts at the end of the +-- buffer and loops down until we hit the sentinal: + +unpackAppendCharsStrict :: ShortByteString -> Int -> Int -> [Char] -> [Char] +unpackAppendCharsStrict !sbs off len = go (off-1) (off-1 + len) + where + go !sentinal !i acc + | i == sentinal = acc + | otherwise = let !c = indexCharArray (asBA sbs) i + in go sentinal (i-1) (c:acc) + +unpackAppendBytesStrict :: ShortByteString -> Int -> Int -> [Word8] -> [Word8] +unpackAppendBytesStrict !sbs off len = go (off-1) (off-1 + len) + where + go !sentinal !i acc + | i == sentinal = acc + | otherwise = let !w = indexWord8Array (asBA sbs) i + in go sentinal (i-1) (w:acc) + + +------------------------------------------------------------------------ +-- Eq and Ord implementations + +compareBytes :: ShortByteString -> ShortByteString -> Ordering +compareBytes sbs1 sbs2 = + let !len1 = length sbs1 + !len2 = length sbs2 + !len = min len1 len2 + in case compareByteArrays (asBA sbs1) (asBA sbs2) len of + i | i < 0 -> LT + | i > 0 -> GT + | len2 > len1 -> LT + | len2 < len1 -> GT + | otherwise -> EQ + +------------------------------------------------------------------------ +-- Appending and concatenation + +append :: ShortByteString -> ShortByteString -> ShortByteString +append src1 src2 = + let !len1 = length src1 + !len2 = length src2 + in create (checkedAdd "Short.append" len1 len2) $ \dst -> do + copyByteArray (asBA src1) 0 dst 0 len1 + copyByteArray (asBA src2) 0 dst len1 len2 + +concat :: [ShortByteString] -> ShortByteString +concat = \sbss -> + create (totalLen 0 sbss) (\dst -> copy dst 0 sbss) + where + totalLen !acc [] = acc + totalLen !acc (curr : rest) + = totalLen (checkedAdd "Short.concat" acc $ length curr) rest + + copy :: MutableByteArray s -> Int -> [ShortByteString] -> ST s () + copy !_ !_ [] = return () + copy !dst !off (src : sbss) = do + let !len = length src + copyByteArray (asBA src) 0 dst off len + copy dst (off + len) sbss + +-- --------------------------------------------------------------------- +-- Basic interface + +infixr 5 `cons` --same as list (:) +infixl 5 `snoc` + +-- | /O(n)/ Append a byte to the end of a 'ShortByteString' +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +snoc :: ShortByteString -> Word8 -> ShortByteString +snoc = \sbs c -> let len = length sbs + newLen = checkedAdd "Short.snoc" len 1 + in create newLen $ \mba -> do + copyByteArray (asBA sbs) 0 mba 0 len + writeWord8Array mba len c + +-- | /O(n)/ 'cons' is analogous to (:) for lists. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +cons :: Word8 -> ShortByteString -> ShortByteString +cons c = \sbs -> let len = length sbs + newLen = checkedAdd "Short.cons" len 1 + in create newLen $ \mba -> do + writeWord8Array mba 0 c + copyByteArray (asBA sbs) 0 mba 1 len + +-- | /O(1)/ Extract the last element of a ShortByteString, which must be finite and non-empty. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- This is a partial function, consider using 'unsnoc' instead. +-- +-- @since 0.11.3.0 +last :: HasCallStack => ShortByteString -> Word8 +last = \sbs -> case null sbs of + True -> errorEmptySBS "last" + False -> indexWord8Array (asBA sbs) (length sbs - 1) + +-- | /O(n)/ Extract the elements after the head of a ShortByteString, which must be non-empty. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- This is a partial function, consider using 'uncons' instead. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +tail :: HasCallStack => ShortByteString -> ShortByteString +tail = \sbs -> + let l = length sbs + nl = l - 1 + in case null sbs of + True -> errorEmptySBS "tail" + False -> create nl $ \mba -> copyByteArray (asBA sbs) 1 mba 0 nl + +-- | /O(n)/ Extract the 'head' and 'tail' of a ShortByteString, returning 'Nothing' +-- if it is empty. +-- +-- @since 0.11.3.0 +uncons :: ShortByteString -> Maybe (Word8, ShortByteString) +uncons = \sbs -> + let l = length sbs + nl = l - 1 + in if | l <= 0 -> Nothing + | otherwise -> let h = indexWord8Array (asBA sbs) 0 + t = create nl $ \mba -> copyByteArray (asBA sbs) 1 mba 0 nl + in Just (h, t) + +-- | /O(1)/ Extract the first element of a ShortByteString, which must be non-empty. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- This is a partial function, consider using 'uncons' instead. +-- +-- @since 0.11.3.0 +head :: HasCallStack => ShortByteString -> Word8 +head = \sbs -> case null sbs of + True -> errorEmptySBS "head" + False -> indexWord8Array (asBA sbs) 0 + +-- | /O(n)/ Return all the elements of a 'ShortByteString' except the last one. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- This is a partial function, consider using 'unsnoc' instead. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +init :: HasCallStack => ShortByteString -> ShortByteString +init = \sbs -> + let l = length sbs + nl = l - 1 + in case null sbs of + True -> errorEmptySBS "init" + False -> create nl $ \mba -> copyByteArray (asBA sbs) 0 mba 0 nl + +-- | /O(n)/ Extract the 'init' and 'last' of a ShortByteString, returning 'Nothing' +-- if it is empty. +-- +-- @since 0.11.3.0 +unsnoc :: ShortByteString -> Maybe (ShortByteString, Word8) +unsnoc = \sbs -> + let l = length sbs + nl = l - 1 + in if | l <= 0 -> Nothing + | otherwise -> let l' = indexWord8Array (asBA sbs) (l - 1) + i = create nl $ \mba -> copyByteArray (asBA sbs) 0 mba 0 nl + in Just (i, l') + + +-- --------------------------------------------------------------------- +-- Transformations + +-- | /O(n)/ 'map' @f xs@ is the ShortByteString obtained by applying @f@ to each +-- element of @xs@. +-- +-- @since 0.11.3.0 +map :: (Word8 -> Word8) -> ShortByteString -> ShortByteString +map f = \sbs -> + let l = length sbs + ba = asBA sbs + in create l (\mba -> go ba mba 0 l) + where + go :: ByteArray -> MutableByteArray s -> Int -> Int -> ST s () + go !ba !mba !i !l + | i >= l = return () + | otherwise = do + let w = indexWord8Array ba i + writeWord8Array mba i (f w) + go ba mba (i+1) l + + +-- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order. +-- +-- @since 0.11.3.0 +reverse :: ShortByteString -> ShortByteString +reverse = \sbs -> + let l = length sbs + ba = asBA sbs +#if HS_UNALIGNED_ByteArray_OPS_OK + in create l (\mba -> go ba mba l) + where + go :: forall s. ByteArray -> MutableByteArray s -> Int -> ST s () + go !ba !mba !l = do + -- this is equivalent to: (q, r) = l `quotRem` 8 + let q = l `shiftR` 3 + r = l .&. 7 + i' <- goWord8Chunk 0 r + goWord64Chunk i' 0 q + where + + goWord64Chunk :: Int -> Int -> Int -> ST s () + goWord64Chunk !off !i' !cl = loop i' + where + loop :: Int -> ST s () + loop !i + | i >= cl = return () + | otherwise = do + let w = indexWord8ArrayAsWord64 ba (off + (i * 8)) + writeWord64Array mba (cl - 1 - i) (byteSwap64 w) + loop (i+1) + + goWord8Chunk :: Int -> Int -> ST s Int + goWord8Chunk !i' !cl = loop i' + where + loop :: Int -> ST s Int + loop !i + | i >= cl = return i + | otherwise = do + let w = indexWord8Array ba i + writeWord8Array mba (l - 1 - i) w + loop (i+1) +#else + in create l (\mba -> go ba mba 0 l) + where + go :: ByteArray -> MutableByteArray s -> Int -> Int -> ST s () + go !ba !mba !i !l + | i >= l = return () + | otherwise = do + let w = indexWord8Array ba i + writeWord8Array mba (l - 1 - i) w + go ba mba (i+1) l +#endif + + +-- | /O(n)/ The 'intercalate' function takes a 'ShortByteString' and a list of +-- 'ShortByteString's and concatenates the list after interspersing the first +-- argument between each element of the list. +-- +-- @since 0.11.3.0 +intercalate :: ShortByteString -> [ShortByteString] -> ShortByteString +intercalate sep = \case + [] -> empty + [x] -> x -- This branch exists for laziness, not speed + (sbs:t) -> let !totalLen = List.foldl' (\acc chunk -> acc +! length sep +! length chunk) (length sbs) t + in create totalLen (\mba -> + let !l = length sbs + in copyByteArray (asBA sbs) 0 mba 0 l >> go mba l t) + where + ba = asBA sep + lba = length sep + + go :: MutableByteArray s -> Int -> [ShortByteString] -> ST s () + go _ _ [] = pure () + go mba !off (chunk:chunks) = do + let lc = length chunk + copyByteArray ba 0 mba off lba + copyByteArray (asBA chunk) 0 mba (off + lba) lc + go mba (off + lc + lba) chunks + (+!) = checkedAdd "Short.intercalate" + + +-- --------------------------------------------------------------------- +-- Reducing 'ShortByteString's + +-- | 'foldl', applied to a binary operator, a starting value (typically +-- the left-identity of the operator), and a ShortByteString, reduces the +-- ShortByteString using the binary operator, from left to right. +-- +-- @since 0.11.3.0 +foldl :: (a -> Word8 -> a) -> a -> ShortByteString -> a +foldl f v = List.foldl f v . unpack + +-- | 'foldl'' is like 'foldl', but strict in the accumulator. +-- +-- @since 0.11.3.0 +foldl' :: (a -> Word8 -> a) -> a -> ShortByteString -> a +foldl' f v = List.foldl' f v . unpack + +-- | 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a ShortByteString, +-- reduces the ShortByteString using the binary operator, from right to left. +-- +-- @since 0.11.3.0 +foldr :: (Word8 -> a -> a) -> a -> ShortByteString -> a +foldr k v = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = v + | otherwise = k (w n) (go (n + 1)) + in go 0 +{-# INLINE foldr #-} + +-- | 'foldr'' is like 'foldr', but strict in the accumulator. +-- +-- @since 0.11.3.0 +foldr' :: (Word8 -> a -> a) -> a -> ShortByteString -> a +foldr' k v = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !ix !v' | ix < 0 = v' + | otherwise = go (ix - 1) (k (w ix) v') + in go (l - 1) v +{-# INLINE foldr' #-} + +-- | 'foldl1' is a variant of 'foldl' that has no starting value +-- argument, and thus must be applied to non-empty 'ShortByteString's. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- @since 0.11.3.0 +foldl1 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ShortByteString -> Word8 +foldl1 k = List.foldl1 k . unpack + +-- | 'foldl1'' is like 'foldl1', but strict in the accumulator. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- @since 0.11.3.0 +foldl1' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ShortByteString -> Word8 +foldl1' k = List.foldl1' k . unpack + +-- | 'foldr1' is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty 'ShortByteString's +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- @since 0.11.3.0 +foldr1 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ShortByteString -> Word8 +foldr1 k = List.foldr1 k . unpack + +-- | 'foldr1'' is a variant of 'foldr1', but is strict in the +-- accumulator. +-- +-- @since 0.11.3.0 +foldr1' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ShortByteString -> Word8 +foldr1' k = \sbs -> if null sbs then errorEmptySBS "foldr1'" else foldr' k (last sbs) (init sbs) + + + +-- --------------------------------------------------------------------- +-- Special folds + +-- | /O(n)/ Applied to a predicate and a 'ShortByteString', 'all' determines +-- if all elements of the 'ShortByteString' satisfy the predicate. +-- +-- @since 0.11.3.0 +all :: (Word8 -> Bool) -> ShortByteString -> Bool +all k = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = True + | otherwise = k (w n) && go (n + 1) + in go 0 + + +-- | /O(n)/ Applied to a predicate and a 'ShortByteString', 'any' determines if +-- any element of the 'ShortByteString' satisfies the predicate. +-- +-- @since 0.11.3.0 +any :: (Word8 -> Bool) -> ShortByteString -> Bool +any k = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = False + | otherwise = k (w n) || go (n + 1) + in go 0 + + + +-- --------------------------------------------------------------------- +-- Substrings + +-- | /O(n)/ 'take' @n@, applied to a ShortByteString @xs@, returns the prefix +-- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +take :: Int -> ShortByteString -> ShortByteString +take = \n -> \sbs -> let sl = length sbs + in if | n >= sl -> sbs + | n <= 0 -> empty + | otherwise -> + create n $ \mba -> copyByteArray (asBA sbs) 0 mba 0 n + +-- | Similar to 'Prelude.takeWhile', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate. +-- +-- @since 0.11.3.0 +takeWhile :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +takeWhile f = \sbs -> take (findIndexOrLength (not . f) sbs) sbs + +-- | /O(n)/ @'takeEnd' n xs@ is equivalent to @'drop' ('length' xs - n) xs@. +-- Takes @n@ elements from end of bytestring. +-- +-- >>> takeEnd 3 "abcdefg" +-- "efg" +-- >>> takeEnd 0 "abcdefg" +-- "" +-- >>> takeEnd 4 "abc" +-- "abc" +-- +-- @since 0.11.3.0 +takeEnd :: Int -> ShortByteString -> ShortByteString +takeEnd n = \sbs -> let sl = length sbs + in if | n >= sl -> sbs + | n <= 0 -> empty + | otherwise -> create n $ \mba -> copyByteArray (asBA sbs) (max 0 (sl - n)) mba 0 n + + +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate. +-- +-- @'takeWhileEnd' p@ is equivalent to @'reverse' . 'takeWhile' p . 'reverse'@. +-- +-- @since 0.11.3.0 +takeWhileEnd :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +takeWhileEnd f = \sbs -> drop (findFromEndUntil (not . f) sbs) sbs + +-- | /O(n)/ 'drop' @n@ @xs@ returns the suffix of @xs@ after the first n elements, or 'empty' if @n > 'length' xs@. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +drop :: Int -> ShortByteString -> ShortByteString +drop = \n -> \sbs -> + let len = length sbs + in if | n <= 0 -> sbs + | n >= len -> empty + | otherwise -> + let newLen = len - n + in create newLen $ \mba -> copyByteArray (asBA sbs) n mba 0 newLen + +-- | /O(n)/ @'dropEnd' n xs@ is equivalent to @'take' ('length' xs - n) xs@. +-- Drops @n@ elements from end of bytestring. +-- +-- >>> dropEnd 3 "abcdefg" +-- "abcd" +-- >>> dropEnd 0 "abcdefg" +-- "abcdefg" +-- >>> dropEnd 4 "abc" +-- "" +-- +-- @since 0.11.3.0 +dropEnd :: Int -> ShortByteString -> ShortByteString +dropEnd n = \sbs -> let sl = length sbs + nl = sl - n + in if | n >= sl -> empty + | n <= 0 -> sbs + | otherwise -> create nl $ \mba -> copyByteArray (asBA sbs) 0 mba 0 nl + +-- | Similar to 'Prelude.dropWhile', +-- drops the longest (possibly empty) prefix of elements +-- satisfying the predicate and returns the remainder. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +dropWhile :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +dropWhile f = \sbs -> drop (findIndexOrLength (not . f) sbs) sbs + +-- | Similar to 'Prelude.dropWhileEnd', +-- drops the longest (possibly empty) suffix of elements +-- satisfying the predicate and returns the remainder. +-- +-- @'dropWhileEnd' p@ is equivalent to @'reverse' . 'dropWhile' p . 'reverse'@. +-- +-- @since 0.11.3.0 +dropWhileEnd :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +dropWhileEnd f = \sbs -> take (findFromEndUntil (not . f) sbs) sbs + +-- | Returns the longest (possibly empty) suffix of elements which __do not__ +-- satisfy the predicate and the remainder of the string. +-- +-- 'breakEnd' @p@ is equivalent to @'spanEnd' (not . p)@ and to @('takeWhileEnd' (not . p) &&& 'dropWhileEnd' (not . p))@. +-- +-- @since 0.11.3.0 +breakEnd :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +breakEnd p = \sbs -> splitAt (findFromEndUntil p sbs) sbs + +-- | Similar to 'Prelude.break', +-- returns the longest (possibly empty) prefix of elements which __do not__ +-- satisfy the predicate and the remainder of the string. +-- +-- 'break' @p@ is equivalent to @'span' (not . p)@ and to @('takeWhile' (not . p) &&& 'dropWhile' (not . p))@. +-- +-- @since 0.11.3.0 +break :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +break p = \sbs -> case findIndexOrLength p sbs of n -> (take n sbs, drop n sbs) +{-# INLINE break #-} + +-- | Similar to 'Prelude.span', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate and the remainder of the string. +-- +-- 'span' @p@ is equivalent to @'break' (not . p)@ and to @('takeWhile' p &&& 'dropWhile' p)@. +-- +-- @since 0.11.3.0 +span :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +span p = break (not . p) + +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate and the remainder of the string. +-- +-- 'spanEnd' @p@ is equivalent to @'breakEnd' (not . p)@ and to @('takeWhileEnd' p &&& 'dropWhileEnd' p)@. +-- +-- We have +-- +-- > spanEnd (not . isSpace) "x y z" == ("x y ", "z") +-- +-- and +-- +-- > spanEnd (not . isSpace) sbs +-- > == +-- > let (x, y) = span (not . isSpace) (reverse sbs) in (reverse y, reverse x) +-- +-- @since 0.11.3.0 +spanEnd :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +spanEnd p = \sbs -> splitAt (findFromEndUntil (not . p) sbs) sbs + +-- | /O(n)/ 'splitAt' @n sbs@ is equivalent to @('take' n sbs, 'drop' n sbs)@. +-- +-- Note: copies the substrings +-- +-- @since 0.11.3.0 +splitAt :: Int -> ShortByteString -> (ShortByteString, ShortByteString) +splitAt n = \sbs -> if + | n <= 0 -> (empty, sbs) + | otherwise -> + let slen = length sbs + in if | n >= slen -> (sbs, empty) + | otherwise -> + let rlen = slen - n + lsbs = create n $ \mba -> copyByteArray (asBA sbs) 0 mba 0 n + rsbs = create rlen $ \mba -> copyByteArray (asBA sbs) n mba 0 rlen + in (lsbs, rsbs) + +-- | /O(n)/ Break a 'ShortByteString' into pieces separated by the byte +-- argument, consuming the delimiter. I.e. +-- +-- > split 10 "a\nb\nd\ne" == ["a","b","d","e"] -- fromEnum '\n' == 10 +-- > split 97 "aXaXaXa" == ["","X","X","X",""] -- fromEnum 'a' == 97 +-- > split 120 "x" == ["",""] -- fromEnum 'x' == 120 +-- > split undefined "" == [] -- and not [""] +-- +-- and +-- +-- > intercalate [c] . split c == id +-- > split == splitWith . (==) +-- +-- Note: copies the substrings +-- +-- @since 0.11.3.0 +split :: Word8 -> ShortByteString -> [ShortByteString] +split w = splitWith (== w) + + +-- | /O(n)/ Splits a 'ShortByteString' into components delimited by +-- separators, where the predicate returns True for a separator element. +-- The resulting components do not contain the separators. Two adjacent +-- separators result in an empty component in the output. eg. +-- +-- > splitWith (==97) "aabbaca" == ["","","bb","c",""] -- fromEnum 'a' == 97 +-- > splitWith undefined "" == [] -- and not [""] +-- +-- @since 0.11.3.0 +splitWith :: (Word8 -> Bool) -> ShortByteString -> [ShortByteString] +splitWith p = \sbs -> if + | null sbs -> [] + | otherwise -> go sbs + where + go sbs' + | null sbs' = [empty] + | otherwise = + case break p sbs' of + (a, b) + | null b -> [a] + | otherwise -> a : go (tail b) + + +-- | /O(n)/ The 'stripSuffix' function takes two ShortByteStrings and returns 'Just' +-- the remainder of the second iff the first is its suffix, and otherwise +-- 'Nothing'. +-- +-- @since 0.11.3.0 +stripSuffix :: ShortByteString -> ShortByteString -> Maybe ShortByteString +stripSuffix sbs1 = \sbs2 -> do + let l1 = length sbs1 + l2 = length sbs2 + if | isSuffixOf sbs1 sbs2 -> + if null sbs1 + then Just sbs2 + else Just $! create (l2 - l1) $ \dst -> do + copyByteArray (asBA sbs2) 0 dst 0 (l2 - l1) + | otherwise -> Nothing + +-- | /O(n)/ The 'stripPrefix' function takes two ShortByteStrings and returns 'Just' +-- the remainder of the second iff the first is its prefix, and otherwise +-- 'Nothing'. +-- +-- @since 0.11.3.0 +stripPrefix :: ShortByteString -> ShortByteString -> Maybe ShortByteString +stripPrefix sbs1 = \sbs2 -> do + let l1 = length sbs1 + l2 = length sbs2 + if | isPrefixOf sbs1 sbs2 -> + if null sbs1 + then Just sbs2 + else Just $! create (l2 - l1) $ \dst -> do + copyByteArray (asBA sbs2) l1 dst 0 (l2 - l1) + | otherwise -> Nothing + + +-- --------------------------------------------------------------------- +-- Unfolds and replicates + + +-- | /O(n)/ 'replicate' @n x@ is a ShortByteString of length @n@ with @x@ +-- the value of every element. The following holds: +-- +-- > replicate w c = unfoldr w (\u -> Just (u,u)) c +-- +-- @since 0.11.3.0 +replicate :: Int -> Word8 -> ShortByteString +replicate w c + | w <= 0 = empty + | otherwise = create w (\mba -> setByteArray mba 0 w (fromIntegral c)) + + +-- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' +-- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a +-- ShortByteString from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the ShortByteString or returns +-- 'Just' @(a,b)@, in which case, @a@ is the next byte in the string, +-- and @b@ is the seed value for further production. +-- +-- This function is not efficient/safe. It will build a list of @[Word8]@ +-- and run the generator until it returns `Nothing`, otherwise recurse infinitely, +-- then finally create a 'ShortByteString'. +-- +-- If you know the maximum length, consider using 'unfoldrN'. +-- +-- Examples: +-- +-- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0 +-- > == pack [0, 1, 2, 3, 4, 5] +-- +-- @since 0.11.3.0 +unfoldr :: (a -> Maybe (Word8, a)) -> a -> ShortByteString +unfoldr f = \x0 -> packBytesRev $ go x0 [] + where + go x words' = case f x of + Nothing -> words' + Just (w, x') -> go x' (w:words') + +-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a ShortByteString from a seed +-- value. However, the length of the result is limited by the first +-- argument to 'unfoldrN'. This function is more efficient than 'unfoldr' +-- when the maximum length of the result is known. +-- +-- The following equation relates 'unfoldrN' and 'unfoldr': +-- +-- > fst (unfoldrN n f s) == take n (unfoldr f s) +-- +-- @since 0.11.3.0 +unfoldrN :: forall a. Int -> (a -> Maybe (Word8, a)) -> a -> (ShortByteString, Maybe a) +unfoldrN i f = \x0 -> + if | i < 0 -> (empty, Just x0) + | otherwise -> createAndTrim i $ \mba -> go mba x0 0 + + where + go :: forall s. MutableByteArray s -> a -> Int -> ST s (Int, Maybe a) + go !mba !x !n = go' x n + where + go' :: a -> Int -> ST s (Int, Maybe a) + go' !x' !n' + | n' == i = return (n', Just x') + | otherwise = case f x' of + Nothing -> return (n', Nothing) + Just (w, x'') -> do + writeWord8Array mba n' w + go' x'' (n'+1) +{-# INLINE unfoldrN #-} + + + +-- -------------------------------------------------------------------- +-- Predicates + +-- | Check whether one string is a substring of another. +-- +-- @since 0.11.3.0 +isInfixOf :: ShortByteString -> ShortByteString -> Bool +isInfixOf sbs = \s -> null sbs || not (null $ snd $ (GHC.Exts.inline breakSubstring) sbs s) + +-- |/O(n)/ The 'isPrefixOf' function takes two ShortByteStrings and returns 'True' +-- iff the first is a prefix of the second. +-- +-- @since 0.11.3.0 +isPrefixOf :: ShortByteString -> ShortByteString -> Bool +isPrefixOf sbs1 = \sbs2 -> do + let l1 = length sbs1 + l2 = length sbs2 + if | l1 == 0 -> True + | l2 < l1 -> False + | otherwise -> + let i = compareByteArraysOff (asBA sbs1) 0 (asBA sbs2) 0 l1 + in i == 0 + +-- | /O(n)/ The 'isSuffixOf' function takes two ShortByteStrings and returns 'True' +-- iff the first is a suffix of the second. +-- +-- The following holds: +-- +-- > isSuffixOf x y == reverse x `isPrefixOf` reverse y +-- +-- @since 0.11.3.0 +isSuffixOf :: ShortByteString -> ShortByteString -> Bool +isSuffixOf sbs1 = \sbs2 -> do + let l1 = length sbs1 + l2 = length sbs2 + if | l1 == 0 -> True + | l2 < l1 -> False + | otherwise -> + let i = compareByteArraysOff (asBA sbs1) 0 (asBA sbs2) (l2 - l1) l1 + in i == 0 + +-- | Break a string on a substring, returning a pair of the part of the +-- string prior to the match, and the rest of the string. +-- +-- The following relationships hold: +-- +-- > break (== c) l == breakSubstring (singleton c) l +-- +-- For example, to tokenise a string, dropping delimiters: +-- +-- > tokenise x y = h : if null t then [] else tokenise x (drop (length x) t) +-- > where (h,t) = breakSubstring x y +-- +-- To skip to the first occurrence of a string: +-- +-- > snd (breakSubstring x y) +-- +-- To take the parts of a string before a delimiter: +-- +-- > fst (breakSubstring x y) +-- +-- Note that calling `breakSubstring x` does some preprocessing work, so +-- you should avoid unnecessarily duplicating breakSubstring calls with the same +-- pattern. +-- +-- @since 0.11.3.0 +breakSubstring :: ShortByteString -- ^ String to search for + -> ShortByteString -- ^ String to search in + -> (ShortByteString, ShortByteString) -- ^ Head and tail of string broken at substring +breakSubstring pat = + case lp of + 0 -> (empty,) + 1 -> breakByte (head pat) + _ -> if lp * 8 <= finiteBitSize (0 :: Word) + then shift + else karpRabin + where + lp = length pat + karpRabin :: ShortByteString -> (ShortByteString, ShortByteString) + karpRabin src + | length src < lp = (src,empty) + | otherwise = search (rollingHash $ take lp src) lp + where + k = 2891336453 :: Word32 + rollingHash = foldl' (\h b -> h * k + fromIntegral b) 0 + hp = rollingHash pat + m = k ^ lp + get = fromIntegral . unsafeIndex src + search !hs !i + | hp == hs && pat == take lp b = u + | length src <= i = (src, empty) -- not found + | otherwise = search hs' (i + 1) + where + u@(_, b) = splitAt (i - lp) src + hs' = hs * k + + get i - + m * get (i - lp) + {-# INLINE karpRabin #-} + + shift :: ShortByteString -> (ShortByteString, ShortByteString) + shift !src + | length src < lp = (src, empty) + | otherwise = search (intoWord $ take lp src) lp + where + intoWord :: ShortByteString -> Word + intoWord = foldl' (\w b -> (w `shiftL` 8) .|. fromIntegral b) 0 + + wp = intoWord pat + mask' = (1 `shiftL` (8 * lp)) - 1 + search !w !i + | w == wp = splitAt (i - lp) src + | length src <= i = (src, empty) + | otherwise = search w' (i + 1) + where + b = fromIntegral (unsafeIndex src i) + w' = mask' .&. ((w `shiftL` 8) .|. b) + {-# INLINE shift #-} + + +-- -------------------------------------------------------------------- +-- Searching ShortByteString + +-- | /O(n)/ 'elem' is the 'ShortByteString' membership predicate. +-- +-- @since 0.11.3.0 +elem :: Word8 -> ShortByteString -> Bool +elem c = \sbs -> case elemIndex c sbs of Nothing -> False ; _ -> True + +-- | /O(n)/ 'filter', applied to a predicate and a ShortByteString, +-- returns a ShortByteString containing those characters that satisfy the +-- predicate. +-- +-- @since 0.11.3.0 +filter :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +filter k = \sbs -> let l = length sbs + in if | l <= 0 -> sbs + | otherwise -> createAndTrim' l $ \mba -> go mba (asBA sbs) l + where + go :: forall s. MutableByteArray s -- mutable output bytestring + -> ByteArray -- input bytestring + -> Int -- length of input bytestring + -> ST s Int + go !mba ba !l = go' 0 0 + where + go' :: Int -- bytes read + -> Int -- bytes written + -> ST s Int + go' !br !bw + | br >= l = return bw + | otherwise = do + let w = indexWord8Array ba br + if k w + then do + writeWord8Array mba bw w + go' (br+1) (bw+1) + else + go' (br+1) bw +{-# INLINE filter #-} + +-- | /O(n)/ The 'find' function takes a predicate and a ShortByteString, +-- and returns the first element in matching the predicate, or 'Nothing' +-- if there is no such element. +-- +-- > find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing +-- +-- @since 0.11.3.0 +find :: (Word8 -> Bool) -> ShortByteString -> Maybe Word8 +find f = \sbs -> case findIndex f sbs of + Just n -> Just (sbs `index` n) + _ -> Nothing +{-# INLINE find #-} + +-- | /O(n)/ The 'partition' function takes a predicate a ShortByteString and returns +-- the pair of ShortByteStrings with elements which do and do not satisfy the +-- predicate, respectively; i.e., +-- +-- > partition p bs == (filter p sbs, filter (not . p) sbs) +-- +-- @since 0.11.3.0 +partition :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +partition k = \sbs -> let len = length sbs + in if | len <= 0 -> (sbs, sbs) + | otherwise -> createAndTrim2 len len $ \mba1 mba2 -> go mba1 mba2 (asBA sbs) len + where + go :: forall s. + MutableByteArray s -- mutable output bytestring1 + -> MutableByteArray s -- mutable output bytestring2 + -> ByteArray -- input bytestring + -> Int -- length of input bytestring + -> ST s (Int, Int) -- (length mba1, length mba2) + go !mba1 !mba2 ba !l = go' 0 0 + where + go' :: Int -- bytes read + -> Int -- bytes written to bytestring 1 + -> ST s (Int, Int) -- (length mba1, length mba2) + go' !br !bw1 + | br >= l = return (bw1, br - bw1) + | otherwise = do + let w = indexWord8Array ba br + if k w + then do + writeWord8Array mba1 bw1 w + go' (br+1) (bw1+1) + else do + writeWord8Array mba2 (br - bw1) w + go' (br+1) bw1 + + +-- -------------------------------------------------------------------- +-- Indexing ShortByteString + +-- | /O(n)/ The 'elemIndex' function returns the index of the first +-- element in the given 'ShortByteString' which is equal to the query +-- element, or 'Nothing' if there is no such element. +-- +-- @since 0.11.3.0 +elemIndex :: Word8 -> ShortByteString -> Maybe Int +elemIndex c = \sbs@(SBS ba#) -> do + let l = length sbs + accursedUnutterablePerformIO $ do + !s <- c_elem_index ba# c (fromIntegral l) + return $! if s < 0 then Nothing else Just (fromIntegral s) + + +-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning +-- the indices of all elements equal to the query element, in ascending order. +-- +-- @since 0.11.3.0 +elemIndices :: Word8 -> ShortByteString -> [Int] +elemIndices k = findIndices (==k) + +-- | count returns the number of times its argument appears in the ShortByteString +-- +-- @since 0.11.3.0 +count :: Word8 -> ShortByteString -> Int +count w = \sbs@(SBS ba#) -> accursedUnutterablePerformIO $ + fromIntegral <$> BS.c_count_ba ba# (fromIntegral $ length sbs) w + +-- | /O(n)/ The 'findIndex' function takes a predicate and a 'ShortByteString' and +-- returns the index of the first element in the ShortByteString +-- satisfying the predicate. +-- +-- @since 0.11.3.0 +findIndex :: (Word8 -> Bool) -> ShortByteString -> Maybe Int +findIndex k = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = Nothing + | k (w n) = Just n + | otherwise = go (n + 1) + in go 0 +{-# INLINE findIndex #-} + + +-- | /O(n)/ The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending order. +-- +-- @since 0.11.3.0 +findIndices :: (Word8 -> Bool) -> ShortByteString -> [Int] +findIndices k = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = [] + | k (w n) = n : go (n + 1) + | otherwise = go (n + 1) + in go 0 + +------------------------------------------------------------------------ +-- Exported low level operations + +copyToPtr :: ShortByteString -- ^ source data + -> Int -- ^ offset into source + -> Ptr a -- ^ destination + -> Int -- ^ number of bytes to copy + -> IO () +copyToPtr src off dst len = + stToIO $ + copyByteArrayToAddr (asBA src) off dst len + +createFromPtr :: Ptr a -- ^ source data + -> Int -- ^ number of bytes to copy + -> IO ShortByteString +createFromPtr !ptr len = + stToIO $ do + mba <- newByteArray len + copyAddrToByteArray ptr mba 0 len + ShortByteString <$> unsafeFreezeByteArray mba + + +------------------------------------------------------------------------ +-- Primop wrappers + +indexCharArray :: ByteArray -> Int -> Char +indexCharArray (ByteArray ba#) (I# i#) = C# (indexCharArray# ba# i#) + +indexWord8Array :: ByteArray -> Int -> Word8 +indexWord8Array (ByteArray ba#) (I# i#) = W8# (indexWord8Array# ba# i#) + +#if HS_UNALIGNED_ByteArray_OPS_OK +indexWord8ArrayAsWord64 :: ByteArray -> Int -> Word64 +indexWord8ArrayAsWord64 (ByteArray ba#) (I# i#) = W64# (indexWord8ArrayAsWord64# ba# i#) +#endif + +newByteArray :: Int -> ST s (MutableByteArray s) +newByteArray len@(I# len#) = + assert (len >= 0) $ + ST $ \s -> case newByteArray# len# s of + (# s', mba# #) -> (# s', MutableByteArray mba# #) + +unsafeFreezeByteArray :: MutableByteArray s -> ST s ByteArray +unsafeFreezeByteArray (MutableByteArray mba#) = + ST $ \s -> case unsafeFreezeByteArray# mba# s of + (# s', ba# #) -> (# s', ByteArray ba# #) + +writeWord8Array :: MutableByteArray s -> Int -> Word8 -> ST s () +writeWord8Array (MutableByteArray mba#) (I# i#) (W8# w#) = + ST $ \s -> case writeWord8Array# mba# i# w# s of + s' -> (# s', () #) + +#if HS_UNALIGNED_ByteArray_OPS_OK +writeWord64Array :: MutableByteArray s -> Int -> Word64 -> ST s () +writeWord64Array (MutableByteArray mba#) (I# i#) (W64# w#) = + ST $ \s -> case writeWord64Array# mba# i# w# s of + s' -> (# s', () #) +#endif + +copyAddrToByteArray :: Ptr a -> MutableByteArray RealWorld -> Int -> Int -> ST RealWorld () +copyAddrToByteArray (Ptr src#) (MutableByteArray dst#) (I# dst_off#) (I# len#) = + ST $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of + s' -> (# s', () #) + +copyByteArrayToAddr :: ByteArray -> Int -> Ptr a -> Int -> ST RealWorld () +copyByteArrayToAddr (ByteArray src#) (I# src_off#) (Ptr dst#) (I# len#) = + ST $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of + s' -> (# s', () #) + +copyByteArray :: ByteArray -> Int -> MutableByteArray s -> Int -> Int -> ST s () +copyByteArray (ByteArray src#) (I# src_off#) (MutableByteArray dst#) (I# dst_off#) (I# len#) = + ST $ \s -> case copyByteArray# src# src_off# dst# dst_off# len# s of + s' -> (# s', () #) + +setByteArray :: MutableByteArray s -> Int -> Int -> Int -> ST s () +setByteArray (MutableByteArray dst#) (I# off#) (I# len#) (I# c#) = + ST $ \s -> case setByteArray# dst# off# len# c# s of + s' -> (# s', () #) + +copyMutableByteArray :: MutableByteArray s -> Int -> MutableByteArray s -> Int -> Int -> ST s () +copyMutableByteArray (MutableByteArray src#) (I# src_off#) (MutableByteArray dst#) (I# dst_off#) (I# len#) = + ST $ \s -> case copyMutableByteArray# src# src_off# dst# dst_off# len# s of + s' -> (# s', () #) + + +------------------------------------------------------------------------ +-- FFI imports +-- +compareByteArrays :: ByteArray -> ByteArray -> Int -> Int +compareByteArrays ba1 ba2 = compareByteArraysOff ba1 0 ba2 0 + +compareByteArraysOff :: ByteArray -- ^ array 1 + -> Int -- ^ offset for array 1 + -> ByteArray -- ^ array 2 + -> Int -- ^ offset for array 2 + -> Int -- ^ length to compare + -> Int -- ^ like memcmp +compareByteArraysOff (ByteArray ba1#) (I# ba1off#) (ByteArray ba2#) (I# ba2off#) (I# len#) = + I# (compareByteArrays# ba1# ba1off# ba2# ba2off# len#) + +------------------------------------------------------------------------ +-- Primop replacements + +copyAddrToByteArray# :: Addr# + -> MutableByteArray# RealWorld -> Int# + -> Int# + -> State# RealWorld -> State# RealWorld + +copyByteArrayToAddr# :: ByteArray# -> Int# + -> Addr# + -> Int# + -> State# RealWorld -> State# RealWorld + +copyByteArray# :: ByteArray# -> Int# + -> MutableByteArray# s -> Int# + -> Int# + -> State# s -> State# s + +copyAddrToByteArray# = GHC.Exts.copyAddrToByteArray# +copyByteArrayToAddr# = GHC.Exts.copyByteArrayToAddr# +copyByteArray# = GHC.Exts.copyByteArray# + +-- | /O(n)./ Construct a new @ShortByteString@ from a @CString@. The +-- resulting @ShortByteString@ is an immutable copy of the original +-- @CString@, and is managed on the Haskell heap. The original +-- @CString@ must be null terminated. +-- +-- @since 0.10.10.0 +packCString :: CString -> IO ShortByteString +packCString cstr = do + len <- BS.c_strlen cstr + packCStringLen (cstr, fromIntegral len) + +-- | /O(n)./ Construct a new @ShortByteString@ from a @CStringLen@. The +-- resulting @ShortByteString@ is an immutable copy of the original @CStringLen@. +-- The @ShortByteString@ is a normal Haskell value and will be managed on the +-- Haskell heap. +-- +-- @since 0.10.10.0 +packCStringLen :: CStringLen -> IO ShortByteString +packCStringLen (cstr, len) | len >= 0 = createFromPtr cstr len +packCStringLen (_, len) = + moduleErrorIO "packCStringLen" ("negative length: " ++ show len) + +-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a +-- null-terminated @CString@. The @CString@ is a copy and will be freed +-- automatically; it must not be stored or used after the +-- subcomputation finishes. +-- +-- @since 0.10.10.0 +useAsCString :: ShortByteString -> (CString -> IO a) -> IO a +useAsCString sbs action = + allocaBytes (l+1) $ \buf -> do + copyToPtr sbs 0 buf (fromIntegral l) + pokeByteOff buf l (0::Word8) + action buf + where l = length sbs + +-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a 'CStringLen'. +-- As for 'useAsCString' this function makes a copy of the original @ShortByteString@. +-- It must not be stored or used after the subcomputation finishes. +-- +-- Beware that this function does not add a terminating @\NUL@ byte at the end of 'CStringLen'. +-- If you need to construct a pointer to a null-terminated sequence, use 'useAsCString' +-- (and measure length independently if desired). +-- +-- @since 0.10.10.0 +useAsCStringLen :: ShortByteString -> (CStringLen -> IO a) -> IO a +useAsCStringLen sbs action = + allocaBytes l $ \buf -> do + copyToPtr sbs 0 buf (fromIntegral l) + action (buf, l) + where l = length sbs + +-- | /O(n)/ Check whether a 'ShortByteString' represents valid UTF-8. +-- +-- @since 0.11.3.0 +isValidUtf8 :: ShortByteString -> Bool +isValidUtf8 sbs@(SBS ba#) = accursedUnutterablePerformIO $ do + let n = length sbs + -- Use a safe FFI call for large inputs to avoid GC synchronization pauses + -- in multithreaded contexts. + -- This specific limit was chosen based on results of a simple benchmark, see: + -- https://github.com/haskell/bytestring/issues/451#issuecomment-991879338 + -- When changing this function, also consider changing the related function: + -- Data.ByteString.isValidUtf8 + i <- if n < 1000000 || not (isPinned ba#) + then cIsValidUtf8BA ba# (fromIntegral n) + else cIsValidUtf8BASafe ba# (fromIntegral n) + IO (\s -> (# touch# ba# s, () #)) + return $ i /= 0 + +-- --------------------------------------------------------------------- +-- Internal utilities + +moduleErrorIO :: HasCallStack => String -> String -> IO a +moduleErrorIO fun msg = throwIO . userError $ moduleErrorMsg fun msg +{-# NOINLINE moduleErrorIO #-} + +moduleErrorMsg :: String -> String -> String +moduleErrorMsg fun msg = "Data.ByteString.Short." ++ fun ++ ':':' ':msg + + +-- Find from the end of the string using predicate. +-- +-- Return '0' if the predicate returns false for the entire ShortByteString. +findFromEndUntil :: (Word8 -> Bool) -> ShortByteString -> Int +findFromEndUntil k sbs = go (length sbs - 1) + where + ba = asBA sbs + go !n | n < 0 = 0 + | k (indexWord8Array ba n) = n + 1 + | otherwise = go (n - 1) + +findIndexOrLength :: (Word8 -> Bool) -> ShortByteString -> Int +findIndexOrLength k sbs = go 0 + where + l = length sbs + ba = asBA sbs + go !n | n >= l = l + | k (indexWord8Array ba n) = n + | otherwise = go (n + 1) + + +packBytesRev :: [Word8] -> ShortByteString +packBytesRev cs = packLenBytesRev (List.length cs) cs + +packLenBytesRev :: Int -> [Word8] -> ShortByteString +packLenBytesRev len ws0 = + create len (\mba -> go mba len ws0) + where + go :: MutableByteArray s -> Int -> [Word8] -> ST s () + go !_ !_ [] = return () + go !mba !i (w:ws) = do + writeWord8Array mba (i - 1) w + go mba (i - 1) ws + + +breakByte :: Word8 -> ShortByteString -> (ShortByteString, ShortByteString) +breakByte c sbs = case elemIndex c sbs of + Nothing -> (sbs, empty) + Just n -> (take n sbs, drop n sbs) + +-- Common up near identical calls to `error' to reduce the number +-- constant strings created when compiled: +errorEmptySBS :: HasCallStack => String -> a +errorEmptySBS fun = moduleError fun "empty ShortByteString" +{-# NOINLINE errorEmptySBS #-} + +moduleError :: HasCallStack => String -> String -> a +moduleError fun msg = error (moduleErrorMsg fun msg) +{-# NOINLINE moduleError #-} + diff --git a/Data/ByteString/Unsafe.hs b/Data/ByteString/Unsafe.hs --- a/Data/ByteString/Unsafe.hs +++ b/Data/ByteString/Unsafe.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ -{-# LANGUAGE MagicHash #-} -#endif +{-# LANGUAGE Unsafe #-} -- | -- Module : Data.ByteString.Unsafe @@ -21,73 +18,48 @@ module Data.ByteString.Unsafe ( -- * Unchecked access - unsafeHead, -- :: ByteString -> Word8 - unsafeTail, -- :: ByteString -> ByteString - unsafeIndex, -- :: ByteString -> Int -> Word8 - unsafeTake, -- :: Int -> ByteString -> ByteString - unsafeDrop, -- :: Int -> ByteString -> ByteString + unsafeHead, + unsafeTail, + unsafeInit, + unsafeLast, + unsafeIndex, + unsafeTake, + unsafeDrop, -- * Low level interaction with CStrings -- ** Using ByteStrings with functions for CStrings - unsafeUseAsCString, -- :: ByteString -> (CString -> IO a) -> IO a - unsafeUseAsCStringLen, -- :: ByteString -> (CStringLen -> IO a) -> IO a + unsafeUseAsCString, + unsafeUseAsCStringLen, -- ** Converting CStrings to ByteStrings - unsafePackCString, -- :: CString -> IO ByteString - unsafePackCStringLen, -- :: CStringLen -> IO ByteString - unsafePackMallocCString,-- :: CString -> IO ByteString + unsafePackCString, + unsafePackCStringLen, + unsafePackMallocCString, + unsafePackMallocCStringLen, -#if defined(__GLASGOW_HASKELL__) - unsafePackAddress, -- :: Addr# -> IO ByteString - unsafePackAddressLen, -- :: Int -> Addr# -> IO ByteString - unsafePackCStringFinalizer, -- :: Ptr Word8 -> Int -> IO () -> IO ByteString - unsafeFinalize, -- :: ByteString -> IO () -#endif + unsafePackAddress, + unsafePackAddressLen, + unsafePackCStringFinalizer, + unsafeFinalize, ) where import Data.ByteString.Internal import Foreign.ForeignPtr (newForeignPtr_, newForeignPtr, withForeignPtr) -import Foreign.Ptr (Ptr, plusPtr, castPtr) import Foreign.Storable (Storable(..)) import Foreign.C.String (CString, CStringLen) -#ifndef __NHC__ import Control.Exception (assert) -#endif import Data.Word (Word8) -#if defined(__GLASGOW_HASKELL__) import qualified Foreign.ForeignPtr as FC (finalizeForeignPtr) import qualified Foreign.Concurrent as FC (newForeignPtr) ---import Data.Generics (Data(..), Typeable(..)) - -import GHC.Prim (Addr#) -import GHC.Ptr (Ptr(..)) -#endif - --- An alternative to Control.Exception (assert) for nhc98 -#ifdef __NHC__ -#define assert assertS "__FILE__ : __LINE__" -assertS :: String -> Bool -> a -> a -assertS _ True = id -assertS s False = error ("assertion failed at "++s) -#endif - --- ----------------------------------------------------------------------------- --- --- Useful macros, until we have bang patterns --- - -#define STRICT1(f) f a | a `seq` False = undefined -#define STRICT2(f) f a b | a `seq` b `seq` False = undefined -#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined -#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined -#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined +import GHC.Exts (Addr#) +import GHC.Ptr (Ptr(..), castPtr) -- --------------------------------------------------------------------- -- @@ -98,73 +70,56 @@ -- check for the empty case, so there is an obligation on the programmer -- to provide a proof that the ByteString is non-empty. unsafeHead :: ByteString -> Word8 -unsafeHead (PS x s l) = assert (l > 0) $ - inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p s +unsafeHead (BS x l) = assert (l > 0) $ + accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> peek p {-# INLINE unsafeHead #-} -- | A variety of 'tail' for non-empty ByteStrings. 'unsafeTail' omits the -- check for the empty case. As with 'unsafeHead', the programmer must -- provide a separate proof that the ByteString is non-empty. unsafeTail :: ByteString -> ByteString -unsafeTail (PS ps s l) = assert (l > 0) $ PS ps (s+1) (l-1) +unsafeTail (BS ps l) = assert (l > 0) $ BS (plusForeignPtr ps 1) (l-1) {-# INLINE unsafeTail #-} +-- | A variety of 'init' for non-empty ByteStrings. 'unsafeInit' omits the +-- check for the empty case. As with 'unsafeHead', the programmer must +-- provide a separate proof that the ByteString is non-empty. +unsafeInit :: ByteString -> ByteString +unsafeInit (BS ps l) = assert (l > 0) $ BS ps (l-1) +{-# INLINE unsafeInit #-} + +-- | A variety of 'last' for non-empty ByteStrings. 'unsafeLast' omits the +-- check for the empty case. As with 'unsafeHead', the programmer must +-- provide a separate proof that the ByteString is non-empty. +unsafeLast :: ByteString -> Word8 +unsafeLast (BS x l) = assert (l > 0) $ + accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> peekByteOff p (l-1) +{-# INLINE unsafeLast #-} + -- | Unsafe 'ByteString' index (subscript) operator, starting from 0, returning a 'Word8' -- This omits the bounds check, which means there is an accompanying -- obligation on the programmer to ensure the bounds are checked in some -- other way. unsafeIndex :: ByteString -> Int -> Word8 -unsafeIndex (PS x s l) i = assert (i >= 0 && i < l) $ - inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p (s+i) +unsafeIndex (BS x l) i = assert (i >= 0 && i < l) $ + accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> peekByteOff p i {-# INLINE unsafeIndex #-} -- | A variety of 'take' which omits the checks on @n@ so there is an -- obligation on the programmer to provide a proof that @0 <= n <= 'length' xs@. unsafeTake :: Int -> ByteString -> ByteString -unsafeTake n (PS x s l) = assert (0 <= n && n <= l) $ PS x s n +unsafeTake n (BS x l) = assert (0 <= n && n <= l) $ BS x n {-# INLINE unsafeTake #-} -- | A variety of 'drop' which omits the checks on @n@ so there is an -- obligation on the programmer to provide a proof that @0 <= n <= 'length' xs@. unsafeDrop :: Int -> ByteString -> ByteString -unsafeDrop n (PS x s l) = assert (0 <= n && n <= l) $ PS x (s+n) (l-n) +unsafeDrop n (BS x l) = assert (0 <= n && n <= l) $ BS (plusForeignPtr x n) (l-n) {-# INLINE unsafeDrop #-} -#if defined(__GLASGOW_HASKELL__) --- | /O(n)/ Pack a null-terminated sequence of bytes, pointed to by an --- Addr\# (an arbitrary machine address assumed to point outside the --- garbage-collected heap) into a @ByteString@. A much faster way to --- create an Addr\# is with an unboxed string literal, than to pack a --- boxed string. A unboxed string literal is compiled to a static @char --- []@ by GHC. Establishing the length of the string requires a call to --- @strlen(3)@, so the Addr# must point to a null-terminated buffer (as --- is the case with "string"# literals in GHC). Use 'unsafePackAddressLen' --- if you know the length of the string statically. --- --- An example: --- --- > literalFS = unsafePackAddress "literal"# --- --- This function is /unsafe/. If you modify the buffer pointed to by the --- original Addr# this modification will be reflected in the resulting --- @ByteString@, breaking referential transparency. --- --- Note this also won't work if you Add# has embedded '\0' characters in --- the string (strlen will fail). --- -unsafePackAddress :: Addr# -> IO ByteString -unsafePackAddress addr# = do - p <- newForeignPtr_ (castPtr cstr) - l <- c_strlen cstr - return $ PS p 0 (fromIntegral l) - where - cstr :: CString - cstr = Ptr addr# -{-# INLINE unsafePackAddress #-} - -- | /O(1)/ 'unsafePackAddressLen' provides constant-time construction of --- 'ByteStrings' which is ideal for string literals. It packs a sequence +-- 'ByteString's, which is ideal for string literals. It packs a sequence -- of bytes into a 'ByteString', given a raw 'Addr#' to the string, and -- the length of the string. -- @@ -174,16 +129,16 @@ -- argument is incorrect, it is possible to overstep the end of the -- byte array. -- --- * if the underying Addr# is later modified, this change will be --- reflected in resulting @ByteString@, breaking referential +-- * if the underlying 'Addr#' is later modified, this change will be +-- reflected in the resulting 'ByteString', breaking referential -- transparency. -- --- If in doubt, don't use these functions. +-- If in doubt, don't use this function. -- unsafePackAddressLen :: Int -> Addr# -> IO ByteString unsafePackAddressLen len addr# = do p <- newForeignPtr_ (Ptr addr#) - return $ PS p 0 len + return $ BS p len {-# INLINE unsafePackAddressLen #-} -- | /O(1)/ Construct a 'ByteString' given a Ptr Word8 to a buffer, a @@ -193,116 +148,137 @@ -- This function is /unsafe/, it is possible to break referential -- transparency by modifying the underlying buffer pointed to by the -- first argument. Any changes to the original buffer will be reflected --- in the resulting @ByteString@. +-- in the resulting 'ByteString'. -- unsafePackCStringFinalizer :: Ptr Word8 -> Int -> IO () -> IO ByteString unsafePackCStringFinalizer p l f = do fp <- FC.newForeignPtr p f - return $ PS fp 0 l + return $ BS fp l -- | Explicitly run the finaliser associated with a 'ByteString'. -- References to this value after finalisation may generate invalid memory -- references. -- -- This function is /unsafe/, as there may be other --- 'ByteStrings' referring to the same underlying pages. If you use +-- 'ByteString's referring to the same underlying pages. If you use -- this, you need to have a proof of some kind that all 'ByteString's -- ever generated from the underlying byte array are no longer live. -- unsafeFinalize :: ByteString -> IO () -unsafeFinalize (PS p _ _) = FC.finalizeForeignPtr p - -#endif +unsafeFinalize (BS p _) = FC.finalizeForeignPtr p ------------------------------------------------------------------------ -- Packing CStrings into ByteStrings --- | /O(n)/ Build a @ByteString@ from a @CString@. This value will have /no/ +-- | /O(n)/ Build a 'ByteString' from a 'CString'. This value will have /no/ -- finalizer associated to it, and will not be garbage collected by -- Haskell. The ByteString length is calculated using /strlen(3)/, -- and thus the complexity is a /O(n)/. -- --- This function is /unsafe/. If the @CString@ is later modified, this --- change will be reflected in the resulting @ByteString@, breaking +-- This function is /unsafe/. If the 'CString' is later modified, this +-- change will be reflected in the resulting 'ByteString', breaking -- referential transparency. -- unsafePackCString :: CString -> IO ByteString unsafePackCString cstr = do fp <- newForeignPtr_ (castPtr cstr) l <- c_strlen cstr - return $! PS fp 0 (fromIntegral l) + return $! BS fp (fromIntegral l) --- | /O(1)/ Build a @ByteString@ from a @CStringLen@. This value will +-- | /O(1)/ Build a 'ByteString' from a 'CStringLen'. This value will -- have /no/ finalizer associated with it, and will not be garbage -- collected by Haskell. This operation has /O(1)/ complexity as we -- already know the final size, so no /strlen(3)/ is required. -- --- This funtion is /unsafe/. If the original @CStringLen@ is later --- modified, this change will be reflected in the resulting @ByteString@, +-- This function is /unsafe/. If the original 'CStringLen' is later +-- modified, this change will be reflected in the resulting 'ByteString', -- breaking referential transparency. -- unsafePackCStringLen :: CStringLen -> IO ByteString unsafePackCStringLen (ptr,len) = do fp <- newForeignPtr_ (castPtr ptr) - return $! PS fp 0 (fromIntegral len) + return $! BS fp (fromIntegral len) --- | /O(n)/ Build a @ByteString@ from a malloced @CString@. This value will +-- | /O(n)/ Build a 'ByteString' from a malloced 'CString'. This value will -- have a @free(3)@ finalizer associated to it. -- --- This funtion is /unsafe/. If the original @CString@ is later --- modified, this change will be reflected in the resulting @ByteString@, +-- This function is /unsafe/. If the original 'CString' is later +-- modified, this change will be reflected in the resulting 'ByteString', -- breaking referential transparency. -- -- This function is also unsafe if you call its finalizer twice, -- which will result in a /double free/ error, or if you pass it --- a CString not allocated with 'malloc'. +-- a 'CString' not allocated with 'Foreign.Marshal.Alloc.malloc'. -- unsafePackMallocCString :: CString -> IO ByteString unsafePackMallocCString cstr = do fp <- newForeignPtr c_free_finalizer (castPtr cstr) len <- c_strlen cstr - return $! PS fp 0 (fromIntegral len) + return $! BS fp (fromIntegral len) +-- | /O(1)/ Build a 'ByteString' from a malloced 'CStringLen'. This +-- value will have a @free(3)@ finalizer associated to it. +-- +-- This function is /unsafe/. If the original 'CString' is later +-- modified, this change will be reflected in the resulting 'ByteString', +-- breaking referential transparency. +-- +-- This function is also unsafe if you call its finalizer twice, +-- which will result in a /double free/ error, or if you pass it +-- a 'CString' not allocated with 'Foreign.Marshal.Alloc.malloc'. +-- +unsafePackMallocCStringLen :: CStringLen -> IO ByteString +unsafePackMallocCStringLen (cstr, len) = do + fp <- newForeignPtr c_free_finalizer (castPtr cstr) + return $! BS fp len + -- --------------------------------------------------------------------- --- | /O(1) construction/ Use a @ByteString@ with a function requiring a --- @CString@. +-- | /O(1) construction/ Use a 'ByteString' with a function requiring a +-- 'CString'. -- --- This function does zero copying, and merely unwraps a @ByteString@ to --- appear as a @CString@. It is /unsafe/ in two ways: +-- This function does zero copying, and merely unwraps a 'ByteString' to +-- appear as a 'CString'. It is /unsafe/ in two ways: -- --- * After calling this function the @CString@ shares the underlying --- byte buffer with the original @ByteString@. Thus modifying the --- @CString@, either in C, or using poke, will cause the contents of the --- @ByteString@ to change, breaking referential transparency. Other --- @ByteStrings@ created by sharing (such as those produced via 'take' --- or 'drop') will also reflect these changes. Modifying the @CString@ +-- * After calling this function the 'CString' shares the underlying +-- byte buffer with the original 'ByteString'. Thus modifying the +-- 'CString', either in C, or using poke, will cause the contents of the +-- 'ByteString' to change, breaking referential transparency. Other +-- 'ByteString's created by sharing (such as those produced via 'take' +-- or 'drop') will also reflect these changes. Modifying the 'CString' -- will break referential transparency. To avoid this, use --- @useAsCString@, which makes a copy of the original @ByteString@. +-- 'Data.ByteString.useAsCString', which makes a copy of the original 'ByteString'. -- --- * @CStrings@ are often passed to functions that require them to be --- null-terminated. If the original @ByteString@ wasn't null terminated, --- neither will the @CString@ be. It is the programmers responsibility --- to guarantee that the @ByteString@ is indeed null terminated. If in --- doubt, use @useAsCString@. +-- * 'CString's are often passed to functions that require them to be +-- null-terminated. If the original 'ByteString' wasn't null terminated, +-- neither will the 'CString' be. It is the programmers responsibility +-- to guarantee that the 'ByteString' is indeed null terminated. If in +-- doubt, use 'Data.ByteString.useAsCString'. -- +-- * The memory may freed at any point after the subcomputation +-- terminates, so the pointer to the storage must *not* be used +-- after this. +-- unsafeUseAsCString :: ByteString -> (CString -> IO a) -> IO a -unsafeUseAsCString (PS ps s _) ac = withForeignPtr ps $ \p -> ac (castPtr p `plusPtr` s) +unsafeUseAsCString (BS ps _) action = withForeignPtr ps $ \p -> action (castPtr p) +-- Cannot use unsafeWithForeignPtr, because action can diverge --- | /O(1) construction/ Use a @ByteString@ with a function requiring a --- @CStringLen@. --- --- This function does zero copying, and merely unwraps a @ByteString@ to --- appear as a @CStringLen@. It is /unsafe/: +-- | /O(1) construction/ Use a 'ByteString' with a function requiring a +-- 'CStringLen'. -- --- * After calling this function the @CStringLen@ shares the underlying --- byte buffer with the original @ByteString@. Thus modifying the --- @CStringLen@, either in C, or using poke, will cause the contents of the --- @ByteString@ to change, breaking referential transparency. Other --- @ByteStrings@ created by sharing (such as those produced via 'take' --- or 'drop') will also reflect these changes. Modifying the @CStringLen@ +-- This function does zero copying, and merely unwraps a 'ByteString' to +-- appear as a 'CStringLen'. It is /unsafe/: +-- +-- * After calling this function the 'CStringLen' shares the underlying +-- byte buffer with the original 'ByteString'. Thus modifying the +-- 'CStringLen', either in C, or using poke, will cause the contents of the +-- 'ByteString' to change, breaking referential transparency. Other +-- 'ByteString's created by sharing (such as those produced via 'take' +-- or 'drop') will also reflect these changes. Modifying the 'CStringLen' -- will break referential transparency. To avoid this, use --- @useAsCStringLen@, which makes a copy of the original @ByteString@. +-- 'Data.ByteString.useAsCStringLen', which makes a copy of the original 'ByteString'. -- +-- If 'Data.ByteString.empty' is given, it will pass @('Foreign.Ptr.nullPtr', 0)@. unsafeUseAsCStringLen :: ByteString -> (CStringLen -> IO a) -> IO a -unsafeUseAsCStringLen (PS ps s l) f = withForeignPtr ps $ \p -> f (castPtr p `plusPtr` s,l) +unsafeUseAsCStringLen (BS ps l) action = withForeignPtr ps $ \p -> action (castPtr p, l) +-- Cannot use unsafeWithForeignPtr, because action can diverge diff --git a/Data/ByteString/Utils/ByteOrder.hs b/Data/ByteString/Utils/ByteOrder.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Utils/ByteOrder.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} + +#include "MachDeps.h" + +-- | Why does this module exist? There is "GHC.ByteOrder" in base. +-- But that module is /broken/ until base-4.14/ghc-8.10, so we +-- can't rely on it until we drop support for older ghcs. +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/20338 +-- and https://gitlab.haskell.org/ghc/ghc/-/issues/18445 + +module Data.ByteString.Utils.ByteOrder + ( ByteOrder(..) + , hostByteOrder + , whenLittleEndian + , whenBigEndian + ) where + +import GHC.ByteOrder (ByteOrder(..)) + +hostByteOrder :: ByteOrder +hostByteOrder = +#ifdef WORDS_BIGENDIAN + BigEndian +#else + LittleEndian +#endif + +-- | If the host is little-endian, applies the given function to the given arg. +-- If the host is big-endian, returns the second argument unchanged. +whenLittleEndian :: (a -> a) -> a -> a +whenLittleEndian fun val = case hostByteOrder of + LittleEndian -> fun val + BigEndian -> val + +-- | If the host is little-endian, returns the second argument unchanged. +-- If the host is big-endian, applies the given function to the given arg. +whenBigEndian :: (a -> a) -> a -> a +whenBigEndian fun val = case hostByteOrder of + LittleEndian -> val + BigEndian -> fun val diff --git a/Data/ByteString/Utils/UnalignedAccess.hs b/Data/ByteString/Utils/UnalignedAccess.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Utils/UnalignedAccess.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE CPP #-} + +#include "bytestring-cpp-macros.h" + +-- | +-- Module : Data.ByteString.Utils.UnalignedAccess +-- Copyright : (c) Matthew Craven 2023-2024 +-- License : BSD-style +-- Maintainer : clyring@gmail.com +-- Stability : internal +-- Portability : non-portable +-- +-- Primitives for reading and writing at potentially-unaligned memory locations + +module Data.ByteString.Utils.UnalignedAccess + ( unalignedWriteU16 + , unalignedWriteU32 + , unalignedWriteU64 + , unalignedWriteFloat + , unalignedWriteDouble + , unalignedReadU64 + ) where + +import Foreign.Ptr +import Data.Word + + +#if HS_UNALIGNED_ADDR_PRIMOPS_AVAILABLE +import GHC.IO (IO(..)) +import GHC.Word (Word16(..), Word32(..), Word64(..)) +import GHC.Exts + +unalignedWriteU16 :: Word16 -> Ptr Word8 -> IO () +unalignedWriteU16 = coerce $ \(W16# x#) (Ptr p#) s + -> (# writeWord8OffAddrAsWord16# p# 0# x# s, () #) + +unalignedWriteU32 :: Word32 -> Ptr Word8 -> IO () +unalignedWriteU32 = coerce $ \(W32# x#) (Ptr p#) s + -> (# writeWord8OffAddrAsWord32# p# 0# x# s, () #) + +unalignedWriteU64 :: Word64 -> Ptr Word8 -> IO () +unalignedWriteU64 = coerce $ \(W64# x#) (Ptr p#) s + -> (# writeWord8OffAddrAsWord64# p# 0# x# s, () #) + +unalignedWriteFloat :: Float -> Ptr Word8 -> IO () +unalignedWriteFloat = coerce $ \(F# x#) (Ptr p#) s + -> (# writeWord8OffAddrAsFloat# p# 0# x# s, () #) + +unalignedWriteDouble :: Double -> Ptr Word8 -> IO () +unalignedWriteDouble = coerce $ \(D# x#) (Ptr p#) s + -> (# writeWord8OffAddrAsDouble# p# 0# x# s, () #) + +unalignedReadU64 :: Ptr Word8 -> IO Word64 +unalignedReadU64 = coerce $ \(Ptr p#) s + -> case readWord8OffAddrAsWord64# p# 0# s of + (# s', w64# #) -> (# s', W64# w64# #) + +#elif HS_UNALIGNED_POKES_OK +import Foreign.Storable + +unalignedWriteU16 :: Word16 -> Ptr Word8 -> IO () +unalignedWriteU16 x p = poke (castPtr p) x + +unalignedWriteU32 :: Word32 -> Ptr Word8 -> IO () +unalignedWriteU32 x p = poke (castPtr p) x + +unalignedWriteU64 :: Word64 -> Ptr Word8 -> IO () +unalignedWriteU64 x p = poke (castPtr p) x + +unalignedWriteFloat :: Float -> Ptr Word8 -> IO () +unalignedWriteFloat x p = poke (castPtr p) x + +unalignedWriteDouble :: Double -> Ptr Word8 -> IO () +unalignedWriteDouble x p = poke (castPtr p) x + +unalignedReadU64 :: Ptr Word8 -> IO Word64 +unalignedReadU64 p = peek (castPtr p) + +#else +foreign import ccall unsafe "static fpstring.h fps_unaligned_write_u16" + unalignedWriteU16 :: Word16 -> Ptr Word8 -> IO () +foreign import ccall unsafe "static fpstring.h fps_unaligned_write_u32" + unalignedWriteU32 :: Word32 -> Ptr Word8 -> IO () +foreign import ccall unsafe "static fpstring.h fps_unaligned_write_u64" + unalignedWriteU64 :: Word64 -> Ptr Word8 -> IO () +foreign import ccall unsafe "static fpstring.h fps_unaligned_write_HsFloat" + unalignedWriteFloat :: Float -> Ptr Word8 -> IO () +foreign import ccall unsafe "static fpstring.h fps_unaligned_write_HsDouble" + unalignedWriteDouble :: Double -> Ptr Word8 -> IO () +foreign import ccall unsafe "static fpstring.h fps_unaligned_read_u64" + unalignedReadU64 :: Ptr Word8 -> IO Word64 +#endif + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,8 @@ Copyright (c) Don Stewart 2005-2009 - (c) Duncan Coutts 2006-2011 + (c) Duncan Coutts 2006-2015 (c) David Roundy 2003-2005 (c) Simon Meier 2010-2011 + (c) Koz Ross 2021 All rights reserved. diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,205 +0,0 @@ ------------------------------------------------------------------------- - ByteString : Fast, packed strings of bytes ------------------------------------------------------------------------- - -This library provides the Data.ByteString library -- strict and lazy -byte arrays manipulable as strings -- providing very time and space -efficient string and IO operations. - -For very large data requirements, or constraints on heap size, -Data.ByteString.Lazy is provided, a lazy list of bytestring chunks. -Efficient processing of multi-gigabyte data can be achieved this way. - -Requirements: - > Cabal - > GHC 6.4 or greater, or hugs - -Building: - > runhaskell Setup.lhs configure --prefix=/f/g - > runhaskell Setup.lhs build - > runhaskell Setup.lhs install - -After installation, you can run the testsuite as follows: - - > cd tests ; make - or - > cd tests ; make hugs - -For the full test and benchmark suite, you need GHC and Hugs: - - > cd tests ; make everything - -Authors: - ByteString was derived from the GHC PackedString library, - originally written by Bryan O'Sullivan, and then by Simon Marlow. - It was adapted, and greatly extended for darcs by David Roundy, and - others. Don Stewart cleaned up and further extended the implementation. - Duncan Coutts wrote much of the .Lazy code. Don, Duncan and Roman - Leshchinskiy wrote the fusion system. - ------------------------------------------------------------------------- - -Performance, some random numbers (with GHC): - -This table compares the performance of common operations ByteString, -from various string libraries. - -Size of test data: 21256k, Linux 3.2Ghz P4 - - FPS7 SPS PS [a] -++ 0.028 ! ! 1.288 -length 0.000 0.000 0.000 0.131 -pack 0.303 0.502 0.337 - -unpack 3.319* 1.630 7.445 - -compare 0.000 0.000 0.000 0.000 -index 0.000 0.000 0.000 0.000 -map 2.762* 2.917 4.813 7.286 -filter 0.304 2.805 0.954 0.305 -take 0.000 0.000 0.024 0.005 -drop 0.000 0.000 11.768 0.130 -takeWhile 0.000 1.498 0.000 0.000 -dropWhile 0.000 1.985 8.447 0.130 -span 0.000 9.289 11.144 0.131 -break 0.000 9.383 11.268 0.133 -lines 0.052 1.114 1.367 2.790 -unlines 0.048 ! ! 10.950 -words 1.344 2.128 5.644 4.184 -unwords 0.016 ! ! 1.305 -reverse 0.024 12.997 13.018 1.622 -concat 0.000 12.701 11.459 1.163 -cons 0.016 2.064 8.358 0.131 -empty 0.000 0.000 0.000 0.000 -head 0.000 0.000 0.000 0.000 -tail 0.000 0.000 14.490 0.130 -elem 0.000 1.490 0.001 0.000 -last 0.000 - - 0.143 -init 0.000 - - 1.147 -inits 0.414 - - ! -tails 0.460 - - 1.136 -intersperse 0.040 - - 10.517 -any 0.000 - - 0.000 -all 0.000 - - 0.000 -sort 0.168 - - ! -maximum 0.024 - - 0.183 -minimum 0.025 - - 0.185 -replicate 0.000 - - 0.053 -findIndex 0.096 -find 0.120 - - 0.000 -elemIndex 0.000 - - 0.000 -elemIndicies 0.008 - - 0.314 -foldl 0.148 -spanEnd 0.000 -snoc 0.016 -filterChar 0.031 -filterNotChar 0.124 -join 0.016 -split 0.032 -findIndices 0.408 -splitAt 0.000 -lineIndices 0.029 -breakOn 0.000 -breakSpace 0.000 -splitWith 0.329 -dropSpace 0.000 -dropSpaceEnd 0.000 -joinWithChar 0.017 -join / 0.016 -zip 0.960 -zipWith 0.892 -isSubstringOf 0.039 -isPrefixOf 0.000 -isSuffixOf 0.000 -count 0.021 - -Key: FPS6 = FPS 0.6 - SPS = Simon Marlow's packedstring prototype - PS = Data.PackedString - [a] = [Char] - - - = no function exists - ! = stack or memory exhaustion - ------------------------------------------------------------------------- - -== Stress testing really big strings - -Doing some stress testing of FPS, here are some results for 0.5G strings. - -3.2Ghz box, 2G physical mem. - -Size of test data: 524288k -Size of test data: 524288k - Char8 Word8 - -Effectively O(1) or O(m) where m < n - all 0.000 0.000 - any 0.000 0.004 - break 0.000 0.000 - breakChar 0.000 0.000 - breakSpace 0.000 - compare 0.000 - concat 0.000 - drop 0.000 - dropSpace 0.000 - dropSpaceEnd 0.000 - dropWhile 0.000 0.000 - elem 0.000 0.000 - elemIndex 0.000 0.000 - elemIndexLast 0.000 0.000 - empty 0.000 - head 0.000 0.000 - index 0.000 0.000 - init 0.000 - last 0.000 0.000 - length 0.000 - notElem 0.000 0.000 - span 0.000 0.000 - spanChar 0.000 0.000 - spanEnd 0.000 0.000 - splitAt 0.000 - tail 0.000 - take 0.000 - takeWhile 0.000 0.000 - isPrefixOf 0.000 - isSuffixOf 0.000 - addr1 0.000 - addr2 0.000 - -O(n) - ++ 0.676 - map 6.080 5.868 - cons 0.396 0.396 - snoc 0.400 0.400 - find 3.240 - split 1.204 1.200 - lines 2.000 - foldl 3.804 - unwords 0.552 - reverse 0.884 - findIndex 3.128 - filterChar 0.756 0.732 - filter/='f' 8.265 7.012 - filterNotChar 4.456 3.388 - join 0.400 - sort 4.344 - maximum 0.776 0.764 - minimum 0.772 0.776 - replicate 0.008 0.000 - elemIndices 0.240 0.240 - lineIndices 1.092 - joinWithChar 0.400 0.400 - isSubstringOf 0.052 - count 0.748 - -slow O(n) - words 38.722 - group 77.261 - groupBy 96.226 - inits 32.430 - tails 23.225 - findIndices 13.841 15.825 - splitWith 18.445 19.225 - zip 33.926 - zipWith 33.562 - - diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,28 @@ +# ByteString: Fast, Packed Strings of Bytes + +[![Build Status](https://github.com/haskell/bytestring/workflows/ci/badge.svg)](https://github.com/haskell/bytestring/actions?query=workflow%3Aci) [![Hackage](http://img.shields.io/hackage/v/bytestring.svg)](https://hackage.haskell.org/package/bytestring) [![Stackage LTS](http://stackage.org/package/bytestring/badge/lts)](http://stackage.org/lts/package/bytestring) [![Stackage Nightly](http://stackage.org/package/bytestring/badge/nightly)](http://stackage.org/nightly/package/bytestring) + +This library provides the `Data.ByteString` module -- strict and lazy +byte arrays manipulable as strings -- providing very time/space-efficient +string and IO operations. + +For very large data requirements, or constraints on heap size, +`Data.ByteString.Lazy` is provided, a lazy list of bytestring chunks. +Efficient processing of multi-gigabyte data can be achieved this way. + +The library also provides `Data.ByteString.Builder` for efficient construction +of `ByteString` values from smaller pieces during binary serialization. + +Requirements: + + * Cabal 2.2 or greater + * GHC 8.4 or greater + +### Authors + +`ByteString` was derived from the GHC `PackedString` library, +originally written by Bryan O'Sullivan, and then by Simon Marlow. +It was adapted and greatly extended for darcs by David Roundy and +others. Don Stewart and Duncan Coutts cleaned up and further extended +the implementation and added the `.Lazy` code. Simon Meier contributed +the `Builder` feature. diff --git a/TODO b/TODO deleted file mode 100644 --- a/TODO +++ /dev/null @@ -1,71 +0,0 @@ -TODO: - - * back port streams fusion code. - * show instance for LPS - * stress testing - * strictness testing - * rewrite C code to Haskell - * eliminate use of -fno-warn-orphans - - -Todo items ----------- - -* check that api again. - - in particular, unsafeHead/Tail for Char8? - - scanr,scanr1... in Char8 - -* would it make sense to move the IO bits into a different module too? - - System.IO.ByteString - - Data.ByteString.IO - -* can we avoid joinWithByte? - - Hard. Can't do it easily with a rule. - -* think about Data.ByteString.hGetLines. is it needed in the presence of - the cheap "lines =<< Data.ByteString.Lazy.getContents" ? - -* unchunk, Data.ByteString.Lazy -> [Data.ByteString] - - and that'd work for any Lazy.ByteString, not just hGetContents >>= lines - -* It might be nice to have a trim MutableByteArray primitive that can release - the tail of an array back to the GC. This would save copying in cases where - we choose to realloc to save space. This combined with GC-movable strings - might improve fragmentation / space usage for the many small strings case. - -* if we can be sure there is very little variance then it might be interesting to look - into the cases where we're doing slightly worse eg the map/up, filter/up cases - and why we're doing so much better in the up/up case!? that one makes no sense - since we should be doing the exact same thing as the old loopU for the up/up - case - -* then there are the strictness issues eg our current foldl & foldr are - arguably too strict we could fuse unpack/unpackWith if they wern't so strict - -* look at shrinking the chunk size, based on our cache testing. - -* think about horizontal fusion (esp. when considering nofib code) - -* fuseable reverse. - -* 'reverse' is very common in list code, but unnecessary in bytestring - code, since it takes a symmertric view. - look to eliminate it with rules. loopUp . reverse --> loopDown - -* work out how robust the rules are . - -* benchmark against C string library benchmarks - -* work out if we can convince ghc to remove NoAccs in map and filter. - -* Implement Lazy: - scanl1 - partition - unzip - -* fix documentation in Fusion.hs - -* Prelude Data.ByteString.Lazy> List.groupBy (/=) $ [97,99,103,103] - [[97,99,103,103]] - Prelude Data.ByteString.Lazy> groupBy (/=) $ pack [97,99,103,103] - [LPS ["ac","g"],LPS ["g"]] diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE PackageImports, ScopedTypeVariables, BangPatterns #-} -- | -- Copyright : (c) 2011 Simon Meier -- License : BSD3-style (see LICENSE) @@ -7,25 +6,47 @@ -- Stability : experimental -- Portability : tested on GHC only -- --- Benchmark all 'Builder' functions. + module Main (main) where -import Prelude hiding (words) -import Criterion.Main -import Data.Foldable (foldMap) +import Data.Foldable (foldMap) +import Data.Monoid +import Data.Semigroup +import Data.String +import Test.Tasty.Bench -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L +import Prelude hiding (words) +import qualified Data.List as List +import Control.DeepSeq +import Control.Exception -import Data.ByteString.Lazy.Builder -import Data.ByteString.Lazy.Builder.ASCII -import Data.ByteString.Lazy.Builder.BasicEncoding - ( FixedEncoding, BoundedEncoding, (>$<) ) -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E -import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Internal as EI +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 -import Foreign +import Data.ByteString.Builder +import qualified Data.ByteString.Builder.Extra as Extra +import qualified Data.ByteString.Builder.Internal as BI +import Data.ByteString.Builder.Prim (BoundedPrim, FixedPrim, + (>$<)) +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Builder.Prim.Internal as PI +import Foreign +import Foreign.ForeignPtr +import qualified GHC.Exts as Exts +import GHC.Ptr (Ptr(..)) + +import System.Random + +import BenchBoundsCheckFusion +import BenchCount +import BenchCSV +import BenchIndices +import BenchReadInt +import BenchShort + ------------------------------------------------------------------------------ -- Benchmark support ------------------------------------------------------------------------------ @@ -50,11 +71,15 @@ intData :: [Int] intData = [1..nRepl] --- Half of the integers inside the range of an Int and half of them outside. -{-# NOINLINE integerData #-} -integerData :: [Integer] -integerData = map (\x -> fromIntegral x + fromIntegral (maxBound - nRepl `div` 2)) intData +{-# NOINLINE smallIntegerData #-} +smallIntegerData :: [Integer] +smallIntegerData = map fromIntegral intData +{-# NOINLINE largeIntegerData #-} +largeIntegerData :: [Integer] +largeIntegerData = map (* (10 ^ (100 :: Integer))) smallIntegerData + + {-# NOINLINE floatData #-} floatData :: [Float] floatData = map (\x -> (3.14159 * fromIntegral x) ^ (3 :: Int)) intData @@ -72,172 +97,487 @@ lazyByteStringData = case S.splitAt (nRepl `div` 2) byteStringData of (bs1, bs2) -> L.fromChunks [bs1, bs2] +{-# NOINLINE smallChunksData #-} +smallChunksData :: L.ByteString +smallChunksData = L.fromChunks $ List.unfoldr step (byteStringData, 1) + where + step (!s, !i) + | S.null s = Nothing + | otherwise = case S.splitAt i s of + (!s1, !s2) -> Just (s1, (s2, i * 71 `mod` 97)) +{-# NOINLINE byteStringChunksData #-} +byteStringChunksData :: [S.ByteString] +byteStringChunksData = map (S.pack . replicate (4 ) . fromIntegral) intData + +{-# NOINLINE loremIpsum #-} +loremIpsum :: S.ByteString +loremIpsum = S8.unlines $ map S8.pack + [ " Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor" + , "incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis" + , "nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat." + , "Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu" + , "fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in" + , "culpa qui officia deserunt mollit anim id est laborum." + ] + -- benchmark wrappers --------------------- -{-# INLINE benchB #-} benchB :: String -> a -> (a -> Builder) -> Benchmark -benchB name x b = - bench (name ++" (" ++ show nRepl ++ ")") $ - whnf (L.length . toLazyByteString . b) x +{-# INLINE benchB #-} +benchB name x b = benchB' (name ++" (" ++ show nRepl ++ ")") x b +benchB' :: String -> a -> (a -> Builder) -> Benchmark +{-# INLINE benchB' #-} +benchB' name x mkB = + env (BI.newBuffer BI.defaultChunkSize) $ \buf -> + bench name $ whnfAppIO (runBuildStepOn buf . BI.runBuilder . mkB) x + +benchB'_ :: String -> Builder -> Benchmark +{-# INLINE benchB'_ #-} +benchB'_ name b = + env (BI.newBuffer BI.defaultChunkSize) $ \buf -> + bench name $ whnfIO (runBuildStepOn buf (BI.runBuilder b)) + +-- | @runBuilderOn@ runs a @BuildStep@'s actions all on the same @Buffer@. +-- It is used to avoid measuring driver allocation overhead. +runBuildStepOn :: BI.Buffer -> BI.BuildStep () -> IO () +{-# NOINLINE runBuildStepOn #-} +runBuildStepOn (BI.Buffer fp br@(BI.BufferRange op ope)) b = go b + where + !len = ope `minusPtr` op + + go :: BI.BuildStep () -> IO () + go bs = BI.fillWithBuildStep bs doneH fullH insertChunkH br + + doneH :: Ptr Word8 -> () -> IO () + doneH _ _ = touchForeignPtr fp + -- 'touchForeignPtr' is adequate because the given BuildStep + -- will always terminate. (We won't measure an infinite loop!) + + fullH :: Ptr Word8 -> Int -> BI.BuildStep () -> IO () + fullH _ minLen nextStep + | len < minLen = throwIO (ErrorCall "runBuilderOn: action expects too long of a BufferRange") + | otherwise = go nextStep + + insertChunkH :: Ptr Word8 -> S.ByteString -> BI.BuildStep () -> IO () + insertChunkH _ _ nextStep = go nextStep + {-# INLINE benchBInts #-} benchBInts :: String -> ([Int] -> Builder) -> Benchmark benchBInts name = benchB name intData --- | Benchmark a 'FixedEncoding'. Full inlining to enable specialization. +-- | Benchmark a 'FixedPrim'. Full inlining to enable specialization. {-# INLINE benchFE #-} -benchFE :: String -> FixedEncoding Int -> Benchmark -benchFE name = benchBE name . E.fromF +benchFE :: String -> FixedPrim Int -> Benchmark +benchFE name = benchBE name . P.liftFixedToBounded --- | Benchmark a 'BoundedEncoding'. Full inlining to enable specialization. +-- | Benchmark a 'BoundedPrim'. Full inlining to enable specialization. {-# INLINE benchBE #-} -benchBE :: String -> BoundedEncoding Int -> Benchmark +benchBE :: String -> BoundedPrim Int -> Benchmark benchBE name e = - bench (name ++" (" ++ show nRepl ++ ")") $ benchIntEncodingB nRepl e + bench (name ++" (" ++ show nRepl ++ ")") $ whnfIO (benchIntEncodingB nRepl e) -- We use this construction of just looping through @n,n-1,..,1@ to ensure that -- we measure the speed of the encoding and not the speed of generating the -- values to be encoded. {-# INLINE benchIntEncodingB #-} -benchIntEncodingB :: Int -- ^ Maximal 'Int' to write - -> BoundedEncoding Int -- ^ 'BoundedEncoding' to execute - -> IO () -- ^ 'IO' action to benchmark +benchIntEncodingB :: Int -- ^ Maximal 'Int' to write + -> BoundedPrim Int -- ^ 'BoundedPrim' to execute + -> IO () -- ^ 'IO' action to benchmark benchIntEncodingB n0 w | n0 <= 0 = return () | otherwise = do - fpbuf <- mallocForeignPtrBytes (n0 * EI.sizeBound w) + fpbuf <- mallocForeignPtrBytes (n0 * PI.sizeBound w) withForeignPtr fpbuf (loop n0) >> return () where loop !n !op | n <= 0 = return op - | otherwise = EI.runB w n op >>= loop (n - 1) + | otherwise = PI.runB w n op >>= loop (n - 1) +hashInt :: Int -> Int +hashInt x = iterate step x !! 10 + where + step a = e + where b = (a `xor` 61) `xor` (a `shiftR` 16) + c = b + (b `shiftL` 3) + d = c `xor` (c `shiftR` 4) + e = d * 0x27d4eb2d + f = e `xor` (e `shiftR` 15) +w :: Int -> Word8 +w = fromIntegral +hashWord8 :: Word8 -> Word8 +hashWord8 = fromIntegral . hashInt . fromIntegral + +partitionStrict p = nf (S.partition p) . randomStrict $ mkStdGen 98423098 + where randomStrict = fst . S.unfoldrN 10000 (Just . random) + +partitionLazy p = nf (L.partition p) . randomLazy $ (0, mkStdGen 98423098) + where step (k, g) + | k >= 10000 = Nothing + | otherwise = let (x, g') = random g in Just (x, (k + 1, g')) + randomLazy = L.unfoldr step + +easySubstrings, randomSubstrings :: Int -> Int -> (S.ByteString, S.ByteString) +hardSubstrings, pathologicalSubstrings :: Int -> + Int -> (S.ByteString, S.ByteString) + +{-# INLINE easySubstrings #-} +easySubstrings n h = (S.replicate n $ w 1, + S.replicate h $ w 0) + +{-# INLINE randomSubstrings #-} +randomSubstrings n h = (f 48278379 n, f 98403980 h) + where + next' g = let (x, g') = next g in (w x, g') + f g l = fst $ S.unfoldrN l (Just . next') (mkStdGen g) + +{-# INLINE hardSubstrings #-} +hardSubstrings n h = (f 48278379 n, f 98403980 h) + where + next' g = let (x, g') = next g + in (w $ x `mod` 4, g') + f g l = fst $ S.unfoldrN l (Just . next') (mkStdGen g) + +{-# INLINE pathologicalSubstrings #-} +pathologicalSubstrings n h = + (S.replicate n (w 0), + S.concat . replicate (h `div` n) $ S.replicate (n - 1) (w 0) `S.snoc` w 1) + +htmlSubstrings :: S.ByteString -> Int -> Int -> IO (S.ByteString, S.ByteString) +htmlSubstrings s n h = + do i <- randomRIO (0, l - n) + return (S.take n . S.drop i $ s', s') + where + s' = S.take h s + l = S.length s' + -- benchmarks ------------- -sanityCheckInfo :: [String] -sanityCheckInfo = - [ "Sanity checks:" - , " lengths of input data: " ++ show - [ length intData, length floatData, length doubleData, length integerData - , S.length byteStringData, fromIntegral (L.length lazyByteStringData) - ] - ] +sortInputs :: [S.ByteString] +sortInputs = map (`S.take` S.pack [122, 121 .. 32]) [10..25] +foldInputs :: [S.ByteString] +foldInputs = map (\k -> S.pack $ if k <= 6 then take (2 ^ k) [32..95] else concat (replicate (2 ^ (k - 6)) [32..95])) [0..16] + +foldInputsLazy :: [L.ByteString] +foldInputsLazy = map (\k -> L.pack $ if k <= 6 then take (2 ^ k) [32..95] else concat (replicate (2 ^ (k - 6)) [32..95])) [0..16] + +zeroes :: L.ByteString +zeroes = L.replicate 10000 0 + +zeroOneRepeating :: L.ByteString +zeroOneRepeating = L.take 10000 (L.cycle (L.pack [0,1])) + + +largeTraversalInput :: S.ByteString +largeTraversalInput = S.concat (replicate 10 byteStringData) + +smallTraversalInput :: S.ByteString +smallTraversalInput = S8.pack "The quick brown fox" + +asciiBuf, utf8Buf, halfNullBuf, allNullBuf :: Ptr Word8 +asciiBuf = Ptr "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"# +utf8Buf = Ptr "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\xc0\x80xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"# +halfNullBuf = Ptr "\xc0\x80xx\xc0\x80x\xc0\x80\xc0\x80x\xc0\x80\xc0\x80xx\xc0\x80\xc0\x80xxx\xc0\x80x\xc0\x80x\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80xxx\xc0\x80x\xc0\x80xx\xc0\x80\xc0\x80xxxxxxxxxx\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80x\xc0\x80\xc0\x80x\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80xxx"# +allNullBuf = Ptr "\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80"# + +asciiLit, utf8Lit :: Ptr Word8 -> Builder +asciiLit (Ptr p#) = P.cstring p# +utf8Lit (Ptr p#) = P.cstringUtf8 p# + +asciiStr, utf8Str :: String +asciiStr = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" +utf8Str = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\0xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" + main :: IO () main = do - mapM_ putStrLn sanityCheckInfo - putStrLn "" - Criterion.Main.defaultMain - [ bgroup "Data.ByteString.Lazy.Builder" - [ bgroup "Encoding wrappers" + defaultMain + [ bgroup "Data.ByteString.Builder" + [ bgroup "Small payload" + [ benchB'_ "mempty" mempty + , bench "toLazyByteString mempty" $ nf toLazyByteString mempty + , benchB'_ "empty (10000 times)" $ + stimes (10000 :: Int) (Exts.lazy BI.empty) + , benchB'_ "ensureFree 8" (BI.ensureFree 8) + , benchB' "intHost 1" 1 Extra.intHost + , benchB' "UTF-8 String (12B, naive)" "hello world\0" fromString + , benchB'_ "UTF-8 String (12B)" $ utf8Lit (Ptr "hello world\xc0\x80"#) + , benchB' "UTF-8 String (64B, naive)" utf8Str fromString + , benchB'_ "UTF-8 String (64B, one null)" $ utf8Lit utf8Buf + , benchB' + "UTF-8 String (64B, one null, no shared work)" + utf8Buf + utf8Lit + , benchB'_ "UTF-8 String (64B, half nulls)" $ utf8Lit halfNullBuf + , benchB'_ "UTF-8 String (64B, all nulls)" $ utf8Lit allNullBuf + , benchB' + "UTF-8 String (64B, all nulls, no shared work)" + allNullBuf + utf8Lit + , benchB' + "UTF-8 String (1 byte, no shared work)" + (Ptr "\xc0\x80"#) + utf8Lit + , benchB' "ASCII String (12B, naive)" "hello world!" fromString + , benchB'_ "ASCII String (12B)" $ asciiLit (Ptr "hello wurld!"#) + , benchB' "ASCII String (64B, naive)" asciiStr fromString + , benchB'_ "ASCII String (64B)" $ asciiLit asciiBuf + ] + + , bgroup "Encoding wrappers" [ benchBInts "foldMap word8" $ foldMap (word8 . fromIntegral) - , benchBInts "encodeListWithF word8" $ - E.encodeListWithF (fromIntegral >$< E.word8) - , benchB "encodeUnfoldrWithF word8" nRepl $ - E.encodeUnfoldrWithF (fromIntegral >$< E.word8) countToZero - , benchB "encodeByteStringWithF word8" byteStringData $ - E.encodeByteStringWithF E.word8 - , benchB "encodeLazyByteStringWithF word8" lazyByteStringData $ - E.encodeLazyByteStringWithF E.word8 + , benchBInts "primMapListFixed word8" $ + P.primMapListFixed (fromIntegral >$< P.word8) + , benchB "primUnfoldrFixed word8" nRepl $ + P.primUnfoldrFixed (fromIntegral >$< P.word8) countToZero + , benchB "primMapByteStringFixed word8" byteStringData $ + P.primMapByteStringFixed P.word8 + , benchB "primMapLazyByteStringFixed word8" lazyByteStringData $ + P.primMapLazyByteStringFixed P.word8 ] + , bgroup "ByteString insertion" $ + [ benchB "foldMap byteStringInsert" byteStringChunksData + (foldMap Extra.byteStringInsert) + , benchB "foldMap byteString" byteStringChunksData + (foldMap byteString) + , benchB "foldMap byteStringCopy" byteStringChunksData + (foldMap Extra.byteStringCopy) + ] , bgroup "Non-bounded encodings" - [ benchB "foldMap floatDec" floatData $ foldMap floatDec + [ benchB "byteStringHex" byteStringData $ byteStringHex + , benchB "lazyByteStringHex" lazyByteStringData $ lazyByteStringHex + , benchB "foldMap floatDec" floatData $ foldMap floatDec , benchB "foldMap doubleDec" doubleData $ foldMap doubleDec - , benchB "foldMap integerDec" integerData $ foldMap integerDec - , benchB "byteStringHexFixed" byteStringData $ byteStringHexFixed - , benchB "lazyByteStringHexFixed" lazyByteStringData $ lazyByteStringHexFixed + -- Note that the small data corresponds to the intData pre-converted + -- to Integer. + , benchB "foldMap integerDec (small)" smallIntegerData $ foldMap integerDec + , benchB "foldMap integerDec (large)" largeIntegerData $ foldMap integerDec ] ] - , bgroup "Data.ByteString.Lazy.Builder.BasicEncoding" - [ benchFE "char7" $ toEnum >$< E.char7 - , benchFE "char8" $ toEnum >$< E.char8 - , benchBE "charUtf8" $ toEnum >$< E.charUtf8 + , bgroup "Data.ByteString.Builder.Prim" + [ benchFE "char7" $ toEnum >$< P.char7 + , benchFE "char8" $ toEnum >$< P.char8 + , benchBE "charUtf8" $ toEnum >$< P.charUtf8 -- binary encoding - , benchFE "int8" $ fromIntegral >$< E.int8 - , benchFE "word8" $ fromIntegral >$< E.word8 + , benchFE "int8" $ fromIntegral >$< P.int8 + , benchFE "word8" $ fromIntegral >$< P.word8 -- big-endian - , benchFE "int16BE" $ fromIntegral >$< E.int16BE - , benchFE "int32BE" $ fromIntegral >$< E.int32BE - , benchFE "int64BE" $ fromIntegral >$< E.int64BE + , benchFE "int16BE" $ fromIntegral >$< P.int16BE + , benchFE "int32BE" $ fromIntegral >$< P.int32BE + , benchFE "int64BE" $ fromIntegral >$< P.int64BE - , benchFE "word16BE" $ fromIntegral >$< E.word16BE - , benchFE "word32BE" $ fromIntegral >$< E.word32BE - , benchFE "word64BE" $ fromIntegral >$< E.word64BE + , benchFE "word16BE" $ fromIntegral >$< P.word16BE + , benchFE "word32BE" $ fromIntegral >$< P.word32BE + , benchFE "word64BE" $ fromIntegral >$< P.word64BE - , benchFE "floatBE" $ fromIntegral >$< E.floatBE - , benchFE "doubleBE" $ fromIntegral >$< E.doubleBE + , benchFE "floatBE" $ fromIntegral >$< P.floatBE + , benchFE "doubleBE" $ fromIntegral >$< P.doubleBE -- little-endian - , benchFE "int16LE" $ fromIntegral >$< E.int16LE - , benchFE "int32LE" $ fromIntegral >$< E.int32LE - , benchFE "int64LE" $ fromIntegral >$< E.int64LE + , benchFE "int16LE" $ fromIntegral >$< P.int16LE + , benchFE "int32LE" $ fromIntegral >$< P.int32LE + , benchFE "int64LE" $ fromIntegral >$< P.int64LE - , benchFE "word16LE" $ fromIntegral >$< E.word16LE - , benchFE "word32LE" $ fromIntegral >$< E.word32LE - , benchFE "word64LE" $ fromIntegral >$< E.word64LE + , benchFE "word16LE" $ fromIntegral >$< P.word16LE + , benchFE "word32LE" $ fromIntegral >$< P.word32LE + , benchFE "word64LE" $ fromIntegral >$< P.word64LE - , benchFE "floatLE" $ fromIntegral >$< E.floatLE - , benchFE "doubleLE" $ fromIntegral >$< E.doubleLE + , benchFE "floatLE" $ fromIntegral >$< P.floatLE + , benchFE "doubleLE" $ fromIntegral >$< P.doubleLE -- host-dependent - , benchFE "int16Host" $ fromIntegral >$< E.int16Host - , benchFE "int32Host" $ fromIntegral >$< E.int32Host - , benchFE "int64Host" $ fromIntegral >$< E.int64Host - , benchFE "intHost" $ fromIntegral >$< E.intHost + , benchFE "int16Host" $ fromIntegral >$< P.int16Host + , benchFE "int32Host" $ fromIntegral >$< P.int32Host + , benchFE "int64Host" $ fromIntegral >$< P.int64Host + , benchFE "intHost" $ fromIntegral >$< P.intHost - , benchFE "word16Host" $ fromIntegral >$< E.word16Host - , benchFE "word32Host" $ fromIntegral >$< E.word32Host - , benchFE "word64Host" $ fromIntegral >$< E.word64Host - , benchFE "wordHost" $ fromIntegral >$< E.wordHost + , benchFE "word16Host" $ fromIntegral >$< P.word16Host + , benchFE "word32Host" $ fromIntegral >$< P.word32Host + , benchFE "word64Host" $ fromIntegral >$< P.word64Host + , benchFE "wordHost" $ fromIntegral >$< P.wordHost - , benchFE "floatHost" $ fromIntegral >$< E.floatHost - , benchFE "doubleHost" $ fromIntegral >$< E.doubleHost + , benchFE "floatHost" $ fromIntegral >$< P.floatHost + , benchFE "doubleHost" $ fromIntegral >$< P.doubleHost ] - , bgroup "Data.ByteString.Lazy.Builder.BoundedEncoding.ASCII" + , bgroup "Data.ByteString.Builder.Prim.ASCII" [ -- decimal number - benchBE "int8Dec" $ fromIntegral >$< E.int8Dec - , benchBE "int16Dec" $ fromIntegral >$< E.int16Dec - , benchBE "int32Dec" $ fromIntegral >$< E.int32Dec - , benchBE "int64Dec" $ fromIntegral >$< E.int64Dec - , benchBE "intDec" $ fromIntegral >$< E.intDec + benchBE "int8Dec" $ fromIntegral >$< P.int8Dec + , benchBE "int16Dec" $ fromIntegral >$< P.int16Dec + , benchBE "int32Dec" $ fromIntegral >$< P.int32Dec + , benchBE "int64Dec" $ fromIntegral >$< P.int64Dec + , benchBE "intDec" $ fromIntegral >$< P.intDec - , benchBE "word8Dec" $ fromIntegral >$< E.word8Dec - , benchBE "word16Dec" $ fromIntegral >$< E.word16Dec - , benchBE "word32Dec" $ fromIntegral >$< E.word32Dec - , benchBE "word64Dec" $ fromIntegral >$< E.word64Dec - , benchBE "wordDec" $ fromIntegral >$< E.wordDec + , benchBE "word8Dec" $ fromIntegral >$< P.word8Dec + , benchBE "word16Dec" $ fromIntegral >$< P.word16Dec + , benchBE "word32Dec" $ fromIntegral >$< P.word32Dec + , benchBE "word64Dec" $ fromIntegral >$< P.word64Dec + , benchBE "wordDec" $ fromIntegral >$< P.wordDec -- hexadecimal number - , benchBE "word8Hex" $ fromIntegral >$< E.word8Hex - , benchBE "word16Hex" $ fromIntegral >$< E.word16Hex - , benchBE "word32Hex" $ fromIntegral >$< E.word32Hex - , benchBE "word64Hex" $ fromIntegral >$< E.word64Hex - , benchBE "wordHex" $ fromIntegral >$< E.wordHex + , benchBE "word8Hex" $ fromIntegral >$< P.word8Hex + , benchBE "word16Hex" $ fromIntegral >$< P.word16Hex + , benchBE "word32Hex" $ fromIntegral >$< P.word32Hex + , benchBE "word64Hex" $ fromIntegral >$< P.word64Hex + , benchBE "wordHex" $ fromIntegral >$< P.wordHex -- fixed-width hexadecimal numbers - , benchFE "int8HexFixed" $ fromIntegral >$< E.int8HexFixed - , benchFE "int16HexFixed" $ fromIntegral >$< E.int16HexFixed - , benchFE "int32HexFixed" $ fromIntegral >$< E.int32HexFixed - , benchFE "int64HexFixed" $ fromIntegral >$< E.int64HexFixed + , benchFE "int8HexFixed" $ fromIntegral >$< P.int8HexFixed + , benchFE "int16HexFixed" $ fromIntegral >$< P.int16HexFixed + , benchFE "int32HexFixed" $ fromIntegral >$< P.int32HexFixed + , benchFE "int64HexFixed" $ fromIntegral >$< P.int64HexFixed - , benchFE "word8HexFixed" $ fromIntegral >$< E.word8HexFixed - , benchFE "word16HexFixed" $ fromIntegral >$< E.word16HexFixed - , benchFE "word32HexFixed" $ fromIntegral >$< E.word32HexFixed - , benchFE "word64HexFixed" $ fromIntegral >$< E.word64HexFixed + , benchFE "word8HexFixed" $ fromIntegral >$< P.word8HexFixed + , benchFE "word16HexFixed" $ fromIntegral >$< P.word16HexFixed + , benchFE "word32HexFixed" $ fromIntegral >$< P.word32HexFixed + , benchFE "word64HexFixed" $ fromIntegral >$< P.word64HexFixed - , benchFE "floatHexFixed" $ fromIntegral >$< E.floatHexFixed - , benchFE "doubleHexFixed" $ fromIntegral >$< E.doubleHexFixed + , benchFE "floatHexFixed" $ fromIntegral >$< P.floatHexFixed + , benchFE "doubleHexFixed" $ fromIntegral >$< P.doubleHexFixed ] + , bgroup "intersperse" + [ bench "intersperse" $ whnf (S.intersperse 32) byteStringData + , bench "intersperse (unaligned)" $ whnf (S.intersperse 32) (S.drop 1 byteStringData) + ] + , bgroup "intercalate" + [ bench "intercalate (large)" $ whnf (S.intercalate $ S8.pack " and also ") (replicate 300 (S8.pack "expression")) + , bench "intercalate (small)" $ whnf (S.intercalate $ S8.pack "&") (replicate 30 (S8.pack "foo")) + , bench "intercalate (tiny)" $ whnf (S.intercalate $ S8.pack "&") (S8.pack <$> ["foo", "bar", "baz"]) + ] + , bgroup "partition" + [ + bgroup "strict" + [ + bench "mostlyTrueFast" $ partitionStrict (< (w 225)) + , bench "mostlyFalseFast" $ partitionStrict (< (w 10)) + , bench "balancedFast" $ partitionStrict (< (w 128)) + + , bench "mostlyTrueSlow" $ partitionStrict (\x -> hashWord8 x < w 225) + , bench "mostlyFalseSlow" $ partitionStrict (\x -> hashWord8 x < w 10) + , bench "balancedSlow" $ partitionStrict (\x -> hashWord8 x < w 128) + ] + , bgroup "lazy" + [ + bench "mostlyTrueFast" $ partitionLazy (< (w 225)) + , bench "mostlyFalseFast" $ partitionLazy (< (w 10)) + , bench "balancedFast" $ partitionLazy (< (w 128)) + + , bench "mostlyTrueSlow" $ partitionLazy (\x -> hashWord8 x < w 225) + , bench "mostlyFalseSlow" $ partitionLazy (\x -> hashWord8 x < w 10) + , bench "balancedSlow" $ partitionLazy (\x -> hashWord8 x < w 128) + ] + ] + , bgroup "inits" + [ bench "strict" $ nf S.inits byteStringData + , bench "lazy" $ nf L.inits lazyByteStringData + , bench "lazy (small chunks)" $ nf L.inits smallChunksData + ] + , bgroup "tails" + [ bench "strict" $ nf S.tails byteStringData + , bench "lazy" $ nf L.tails lazyByteStringData + ] + , bgroup "splitAtEnd (lazy)" $ let + testSAE op = \bs -> [op i bs | i <- [0,5..L.length bs]] `deepseq` () + {-# INLINE testSAE #-} + in + [ bench "takeEnd" $ + nf (testSAE L.takeEnd) lazyByteStringData + , bench "takeEnd (small chunks)" $ + nf (testSAE L.takeEnd) smallChunksData + , bench "dropEnd" $ + nf (testSAE L.dropEnd) lazyByteStringData + , bench "dropEnd (small chunks)" $ + nf (testSAE L.dropEnd) smallChunksData + ] + , bgroup "sort" $ map (\s -> bench (S8.unpack s) $ nf S.sort s) sortInputs + , bgroup "stimes" $ let st = stimes :: Int -> S.ByteString -> S.ByteString + in + [ bench "strict (tiny)" $ whnf (st 4) (S8.pack "test") + , bench "strict (large)" $ whnf (st 50) byteStringData + ] + , bgroup "words" + [ bench "lorem ipsum" $ nf S8.words loremIpsum + , bench "one huge word" $ nf S8.words byteStringData + ] + , bgroup "folds" + [ bgroup "strict" + [ bgroup "foldl'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldl' (\acc x -> acc + fromIntegral x) (0 :: Int)) s) foldInputs + , bgroup "foldr'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldr' (\x acc -> fromIntegral x + acc) (0 :: Int)) s) foldInputs + , bgroup "foldr1'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldr1' (\x acc -> fromIntegral x + acc)) s) foldInputs + , bgroup "unfoldrN" $ map (\s -> bench (show $ S.length s) $ + nf (S.unfoldrN (S.length s) (\a -> Just (a, a + 1))) 0) foldInputs + , bgroup "mapAccumL" $ map (\s -> bench (show $ S.length s) $ + nf (S.mapAccumL (\acc x -> (acc + fromIntegral x, succ x)) (0 :: Int)) s) foldInputs + , bgroup "mapAccumR" $ map (\s -> bench (show $ S.length s) $ + nf (S.mapAccumR (\acc x -> (fromIntegral x + acc, succ x)) (0 :: Int)) s) foldInputs + , bgroup "scanl" $ map (\s -> bench (show $ S.length s) $ + nf (S.scanl (+) 0) s) foldInputs + , bgroup "scanr" $ map (\s -> bench (show $ S.length s) $ + nf (S.scanr (+) 0) s) foldInputs + , bgroup "filter" $ map (\s -> bench (show $ S.length s) $ + nf (S.filter odd) s) foldInputs + ] + , bgroup "lazy" + [ bgroup "foldl'" $ map (\s -> bench (show $ L.length s) $ + nf (L.foldl' (\acc x -> acc + fromIntegral x) (0 :: Int)) s) foldInputsLazy + , bgroup "foldr'" $ map (\s -> bench (show $ L.length s) $ + nf (L.foldr' (\x acc -> fromIntegral x + acc) (0 :: Int)) s) foldInputsLazy + , bgroup "foldr1'" $ map (\s -> bench (show $ L.length s) $ + nf (L.foldr1' (\x acc -> fromIntegral x + acc)) s) foldInputsLazy + , bgroup "mapAccumL" $ map (\s -> bench (show $ L.length s) $ + nf (L.mapAccumL (\acc x -> (acc + fromIntegral x, succ x)) (0 :: Int)) s) foldInputsLazy + , bgroup "mapAccumR" $ map (\s -> bench (show $ L.length s) $ + nf (L.mapAccumR (\acc x -> (fromIntegral x + acc, succ x)) (0 :: Int)) s) foldInputsLazy + , bgroup "scanl" $ map (\s -> bench (show $ L.length s) $ + nf (L.scanl (+) 0) s) foldInputsLazy + , bgroup "scanr" $ map (\s -> bench (show $ L.length s) $ + nf (L.scanr (+) 0) s) foldInputsLazy + ] + + ] + , bgroup "findIndexOrLength" + [ bench "takeWhile" $ nf (L.takeWhile even) zeroes + , bench "dropWhile" $ nf (L.dropWhile even) zeroes + , bench "break" $ nf (L.break odd) zeroes + , bench "group zeroes" $ nf L.group zeroes + , bench "group zero-one" $ nf L.group zeroOneRepeating + , bench "groupBy (>=)" $ nf (L.groupBy (>=)) zeroes + , bench "groupBy (>)" $ nf (L.groupBy (>)) zeroes + ] + , bgroup "findIndex_" + [ bench "findIndices" $ nf (sum . S.findIndices (\x -> x == 129 || x == 72)) byteStringData + , bench "find" $ nf (S.find (>= 198)) byteStringData + ] + , bgroup "findIndexEnd" + [ bench "findIndexEnd" $ nf (S.findIndexEnd (<= 57)) byteStringData + , bench "elemIndexInd" $ nf (S.elemIndexEnd 42) byteStringData + ] + , bgroup "traversals" + [ bench "map (+1) large" $ nf (S.map (+ 1)) largeTraversalInput + , bench "map (+1) small" $ nf (S.map (+ 1)) smallTraversalInput + ] + , bgroup "unlines" + [ bench "lazy" $ nf L8.unlines (map (L8.pack . show) intData) + , bench "strict" $ nf S8.unlines (map (S8.pack . show) intData) + ] + , benchBoundsCheckFusion + , benchCount + , benchCSV + , benchIndices + , benchReadInt + , benchShort ] diff --git a/bench/BenchBoundsCheckFusion.hs b/bench/BenchBoundsCheckFusion.hs new file mode 100644 --- /dev/null +++ b/bench/BenchBoundsCheckFusion.hs @@ -0,0 +1,103 @@ +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Benchmark that the bounds checks fuse. + +module BenchBoundsCheckFusion (benchBoundsCheckFusion) where + +import Prelude hiding (words) +import Data.Monoid +import Data.Foldable (foldMap) +import Test.Tasty.Bench + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +import Data.ByteString.Builder +import Data.ByteString.Builder.Extra +import Data.ByteString.Builder.Prim + ( FixedPrim, BoundedPrim, (>$<), (>*<) ) +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Builder.Internal as I +import qualified Data.ByteString.Builder.Prim.Internal as I + +import Foreign + +------------------------------------------------------------------------------ +-- Benchmark support +------------------------------------------------------------------------------ + +countToZero :: Int -> Maybe (Int, Int) +countToZero 0 = Nothing +countToZero n = Just (n, n - 1) + + +------------------------------------------------------------------------------ +-- Benchmark +------------------------------------------------------------------------------ + +-- input data (NOINLINE to ensure memoization) +---------------------------------------------- + +-- | Few-enough repetitions to avoid making GC too expensive. +nRepl :: Int +nRepl = 10000 + +{-# NOINLINE intData #-} +intData :: [Int] +intData = [1..nRepl] + +-- benchmark wrappers +--------------------- + +{-# INLINE benchB #-} +benchB :: String -> a -> (a -> Builder) -> Benchmark +benchB name x b = + bench (name ++" (" ++ show nRepl ++ ")") $ + whnf (L.length . toLazyByteString . b) x + +{-# INLINE benchBInts #-} +benchBInts :: String -> ([Int] -> Builder) -> Benchmark +benchBInts name = benchB name intData + + +-- benchmarks +------------- + +benchBoundsCheckFusion :: Benchmark +benchBoundsCheckFusion = bgroup "BoundsCheckFusion" + [ bgroup "Data.ByteString.Builder" + [ benchBInts "foldMap (left-assoc)" $ + foldMap (\x -> (stringUtf8 "s" `mappend` intHost x) `mappend` intHost x) + + , benchBInts "foldMap (right-assoc)" $ + foldMap (\x -> intHost x `mappend` (intHost x `mappend` stringUtf8 "s")) + + , benchBInts "foldMap [manually fused, left-assoc]" $ + foldMap (\x -> stringUtf8 "s" `mappend` P.primBounded (P.liftFixedToBounded $ P.intHost >*< P.intHost) (x, x)) + + , benchBInts "foldMap [manually fused, right-assoc]" $ + foldMap (\x -> P.primBounded (P.liftFixedToBounded $ P.intHost >*< P.intHost) (x, x) `mappend` stringUtf8 "s") + ] + ] + +{-# RULES + +"append/encodeWithB" forall w1 w2 x1 x2. + I.append (P.primBounded w1 x1) (P.primBounded w2 x2) + = P.primBounded (I.pairB w1 w2) (x1, x2) + +"append/encodeWithB/assoc_r" forall w1 w2 x1 x2 b. + I.append (P.primBounded w1 x1) (I.append (P.primBounded w2 x2) b) + = I.append (P.primBounded (I.pairB w1 w2) (x1, x2)) b + +"append/encodeWithB/assoc_l" forall w1 w2 x1 x2 b. + I.append (I.append b (P.primBounded w1 x1)) (P.primBounded w2 x2) + = I.append b (P.primBounded (I.pairB w1 w2) (x1, x2)) + #-} + diff --git a/bench/BenchCSV.hs b/bench/BenchCSV.hs new file mode 100644 --- /dev/null +++ b/bench/BenchCSV.hs @@ -0,0 +1,555 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Copyright : (c) 2010-2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Running example for documentation of Data.ByteString.Builder +-- + +module BenchCSV (benchCSV) where + +-- ************************************************************************** +-- CamHac 2011: An introduction to Data.ByteString.Builder +-- ************************************************************************** + + +{- The Encoding Problem + ---------------------- + + Encoding: Conversion from a Haskell value to a sequence of bytes. + + + Efficient encoding implementation: + + 1. represent sequence of bytes as a list of byte arrays (chunks) + 2. generate chunks that are large on average + 3. avoid intermediate copies/datastructures + + Compositionality: + + 4. support fast append + + + Problem: Provide a library for defining compositional, efficient encodings. + +-} + + + +{- Data.ByteString.Builder + ------------------------------ + + A solution to the "Encoding Problem" (based on the code of blaze-builder). + + Builder creation: + + word8 :: Word8 -> Builder + int64LE :: Int64 -> Builder + floatBE :: Float -> Builder + .... + + + Builder composition via its Monoid instance: + + word8 10 `mappend` floatBE 1.4 + + + Builder execution by converting it to a lazy bytestring: + + toLazyByteString :: Builder -> L.ByteString + +-} + + +{- Typical users of Builders + --------------------------- + + binary, text, aeson, blaze-html, blaze-textual, warp, snap-server, ... + + => they want support for maximal performance! + => use of Builders is rather local: in rendering/encoding functions. + +-} + + + +{- Notable properties + -------------------- + + * Built-in UTF-8 support: very hard to get efficient otherwise. + + stringUtf8 :: String -> Builder + intDec :: Int -> Builder + intHex :: Int -> Builder + + * Fine-grained control over when to copy/reference existing bytestrings + + * EDSL for defining low-level Encodings of bounded values (e.g., Int, Char) + to improve speed of escaping and similar operations. + + * If used together with iteratee-style IO: no 'unsafePerformIO' required + +-} + + +{- An example problem: + --------------------- + + Rendering a table in comma-separated-value (CSV) format using UTF-8 encoded + Unicode characters. + + * We are willing to fuse table-rendering with UTF8-encoding to achieve better + performance. + +-} + +import Control.DeepSeq +import Data.Char (ord) +import Data.Foldable (foldMap) +import Data.Monoid + +import Test.Tasty.Bench + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Builder as B +import Data.ByteString.Builder.Prim.Internal ( (>*<), (>$<) ) +import qualified Data.ByteString.Builder.Prim as E + +-- bytestring benchmarks cannot depend on text because of a circular dependency. +-- Anyways these comparisons are of historical interest only, so disabled for now. +-- A curious soul can re-enable them by moving benchmarks to a separate package +-- and adding text to build-depends. +#ifdef MIN_VERSION_text +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Text.Lazy.Builder as TB +import qualified Data.Text.Lazy.Builder.Int as TB +#endif + +-- Same as above: comparison against DList is of historical interest now, +-- so lets shave off another dependency. +#ifdef MIN_VERSION_dlist +import qualified Data.DList as D +#endif + +------------------------------------------------------------------------------ +-- Simplife CSV Tables +------------------------------------------------------------------------------ + +data Cell = StringC String + | IntC Int + deriving( Eq, Ord, Show ) + +type Row = [Cell] +type Table = [Row] + +-- Example data +strings :: [String] +strings = ["hello", "\"1\"", "λ-wörld"] + +table :: Table +table = [map StringC strings, map IntC [-3..3]] + + +-- | The rendered 'table': +-- +-- > "hello","\"1\"","λ-wörld" +-- > -3,-2,-1,0,1,2,3 +-- + + +-- | A bigger table for benchmarking our encoding functions. +maxiTable :: Table +maxiTable = take 1000 $ cycle table + + +------------------------------------------------------------------------------ +-- String based rendering +------------------------------------------------------------------------------ + +renderString :: String -> String +renderString cs = "\"" ++ concatMap escape cs ++ "\"" + where + escape '\\' = "\\" + escape '\"' = "\\\"" + escape c = return c + +renderCell :: Cell -> String +renderCell (StringC cs) = renderString cs +renderCell (IntC i) = show i + +renderRow :: Row -> String +renderRow [] = "" +renderRow (c:cs) = renderCell c ++ concat [',' : renderCell c' | c' <- cs] + +renderTable :: Table -> String +renderTable rs = concat [renderRow r ++ "\n" | r <- rs] + +-- 1.36 ms +benchString :: Benchmark +benchString = bench "renderTable maxiTable" $ nf renderTable maxiTable + +-- 1.36 ms +benchStringUtf8 :: Benchmark +benchStringUtf8 = bench "utf8 + renderTable maxiTable" $ + nf (L.length . B.toLazyByteString . B.stringUtf8 . renderTable) maxiTable + + +-- using difference lists: 0.91 ms +-- +-- (++) is a performance-grinch! + + +------------------------------------------------------------------------------ +-- Builder based rendering +------------------------------------------------------------------------------ + +-- As a reminder: +-- +-- import Data.ByteString.Builder as B + +renderStringB :: String -> Builder +renderStringB cs = B.charUtf8 '"' <> foldMap escape cs <> B.charUtf8 '"' + where + escape '\\' = B.charUtf8 '\\' <> B.charUtf8 '\\' + escape '\"' = B.charUtf8 '\\' <> B.charUtf8 '"' + escape c = B.charUtf8 c + +renderCellB :: Cell -> Builder +renderCellB (StringC cs) = renderStringB cs +renderCellB (IntC i) = B.intDec i + +renderRowB :: Row -> Builder +renderRowB [] = mempty +renderRowB (c:cs) = + renderCellB c <> mconcat [ B.charUtf8 ',' <> renderCellB c' | c' <- cs ] + +renderTableB :: Table -> Builder +renderTableB rs = mconcat [renderRowB r <> B.charUtf8 '\n' | r <- rs] + +-- 0.81ms +benchBuilderUtf8 :: Benchmark +benchBuilderUtf8 = bench "utf8 + renderTableB maxiTable" $ + nf (L.length . B.toLazyByteString . renderTableB) maxiTable + +-- 1.11x faster than DList + +-- However: touching the whole table 'nf maxiTable' takes 0.27ms + +-- 1.16x faster than DList on the code path other than touching all data +-- (0.91 - 0.27) / (0.82 - 0.27) + + +------------------------------------------------------------------------------ +-- Baseline: Touching all data +------------------------------------------------------------------------------ + +instance NFData Cell where + rnf (StringC cs) = rnf cs + rnf (IntC i) = rnf i + +-- 0.27 ms +benchNF :: Benchmark +benchNF = bench "nf maxiTable" $ nf id maxiTable + + +------------------------------------------------------------------------------ +-- Exploiting bounded encodings +------------------------------------------------------------------------------ + +{- Why 'Bounded Encodings'? + -------------------------- + + Hot code of encoding implementations: + + * Appending Builders: Optimized already. + + * Encoding primitive Haskell values: room for optimization: + + - reduce buffer-free checks + - remove jumps/function calls + - hoist constant values out of inner-loops + (e.g., the loop for encoding the elements of a list) + + * Bounded encoding: + an encoding that never takes more than a fixed number of bytes. + + - intuitively: (Int, Ptr Word8 -> IO (Ptr Word8)) + ^bound ^ low-level encoding function + + - compositional: coalesce buffer-checks, ... + + E.encodeIfB :: (a -> Bool) + -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a + E.charUtf8 :: BoundedPrim Char + (>*<) :: BoundedPrim a -> BoundedPrim b -> BoundedPrim (a, b) + + (>$<) :: (b -> a) -> BoundedPrim a -> BoundedPrim b + + ^ BoundedPrims are contrafunctors; like most data-sinks + + + - Implementation relies heavily on inlining to compute bounds and + low-level encoding code during compilation. +-} + +renderStringBE :: String -> Builder +renderStringBE cs = + B.charUtf8 '"' <> E.primMapListBounded escape cs <> B.charUtf8 '"' + where + escape :: E.BoundedPrim Char + escape = + E.condB (== '\\') (const ('\\', '\\') >$< E.charUtf8 >*< E.charUtf8) $ + E.condB (== '\"') (const ('\\', '\"') >$< E.charUtf8 >*< E.charUtf8) $ + E.charUtf8 + +renderCellBE :: Cell -> Builder +renderCellBE (StringC cs) = renderStringBE cs +renderCellBE (IntC i) = B.intDec i + +renderRowBE :: Row -> Builder +renderRowBE [] = mempty +renderRowBE (c:cs) = + renderCellBE c <> mconcat [ B.charUtf8 ',' <> renderCellBE c' | c' <- cs ] + +renderTableBE :: Table -> Builder +renderTableBE rs = mconcat [renderRowBE r <> B.charUtf8 '\n' | r <- rs] + +-- 0.65 ms +benchBuilderEncodingUtf8 :: Benchmark +benchBuilderEncodingUtf8 = bench "utf8 + renderTableBE maxiTable" $ + nf (L.length . B.toLazyByteString . renderTableBE) maxiTable + + +-- 1.4x faster than DList based + +-- 1.7x faster than DList based on code other than touching all data + + +------------------------------------------------------------------------------ +-- Difference-list based rendering +------------------------------------------------------------------------------ + +#ifdef MIN_VERSION_dlist + +type DString = D.DList Char + +renderStringD :: String -> DString +renderStringD cs = return '"' <> foldMap escape cs <> return '"' + where + escape '\\' = D.fromList "\\\\" + escape '\"' = D.fromList "\\\"" + escape c = return c + +renderCellD :: Cell -> DString +renderCellD (StringC cs) = renderStringD cs +renderCellD (IntC i) = D.fromList $ show i + +renderRowD :: Row -> DString +renderRowD [] = mempty +renderRowD (c:cs) = + renderCellD c <> mconcat [ return ',' <> renderCellD c' | c' <- cs ] + +renderTableD :: Table -> DString +renderTableD rs = mconcat [renderRowD r <> return '\n' | r <- rs] + +-- 0.91 ms +benchDListUtf8 :: Benchmark +benchDListUtf8 = bench "utf8 + renderTableD maxiTable" $ + nf (L.length . B.toLazyByteString . B.stringUtf8 . D.toList . renderTableD) maxiTable + +#endif + +------------------------------------------------------------------------------ +-- Text Builder +------------------------------------------------------------------------------ + +#ifdef MIN_VERSION_text + +renderStringTB :: String -> TB.Builder +renderStringTB cs = TB.singleton '"' <> foldMap escape cs <> TB.singleton '"' + where + escape '\\' = "\\\\" + escape '\"' = "\\\"" + escape c = TB.singleton c + +renderCellTB :: Cell -> TB.Builder +renderCellTB (StringC cs) = renderStringTB cs +renderCellTB (IntC i) = TB.decimal i + +renderRowTB :: Row -> TB.Builder +renderRowTB [] = mempty +renderRowTB (c:cs) = + renderCellTB c <> mconcat [ TB.singleton ',' <> renderCellTB c' | c' <- cs ] + +renderTableTB :: Table -> TB.Builder +renderTableTB rs = mconcat [renderRowTB r <> TB.singleton '\n' | r <- rs] + +-- 0.95 ms +benchTextBuilder :: Benchmark +benchTextBuilder = bench "renderTableTB maxiTable" $ + nf (TL.length . TB.toLazyText . renderTableTB) maxiTable + +-- 1.10 ms +benchTextBuilderUtf8 :: Benchmark +benchTextBuilderUtf8 = bench "utf8 + renderTableTB maxiTable" $ + nf (L.length . TL.encodeUtf8 . TB.toLazyText . renderTableTB) maxiTable + +#endif + +------------------------------------------------------------------------------ +-- Benchmarking +------------------------------------------------------------------------------ + +benchCSV :: Benchmark +benchCSV = bgroup "CSV" + [ benchNF + , benchString + , benchStringUtf8 +#ifdef MIN_VERSION_dlist + , benchDListUtf8 +#endif +#ifdef MIN_VERSION_text + , benchTextBuilder + , benchTextBuilderUtf8 +#endif + , benchBuilderUtf8 + , benchBuilderEncodingUtf8 + ] + where + encodeUtf8CSV = B.toLazyByteString . renderTableBE + + +{- On a Core 2 Duo 2.2 GHz running a 32-bit Linux: + + +touching all data: 0.25 ms +string rendering: 1.36 ms +string rendering + utf8 encoding: 1.36 ms +DList rendering + utf8 encoding: 0.91 ms +builder rendering (incl. utf8): 0.82 ms +builder + faster escaping: 0.65 ms + +text builder: 0.95 ms +text builder + utf8 encoding: 1.10 ms +binary builder + char8 (!!): 1.22 ms +DList render + utf8-light: 4.12 ms + +How to improve further? + * Use packed formats for string literals + - fast memcpy (that's what blaze-html does for tags) + - using Text literals should also help + + +results from criterion: + +benchmarking nf maxiTable +mean: 257.2927 us, lb 255.9210 us, ub 259.6692 us, ci 0.950 +std dev: 9.026280 us, lb 5.887942 us, ub 12.76582 us, ci 0.950 + +benchmarking renderTable maxiTable +mean: 1.358458 ms, lb 1.356732 ms, ub 1.362377 ms, ci 0.950 +std dev: 12.66932 us, lb 7.110377 us, ub 24.97397 us, ci 0.950 + +benchmarking utf8 + renderTable maxiTable +mean: 1.364343 ms, lb 1.362391 ms, ub 1.366973 ms, ci 0.950 +std dev: 11.65388 us, lb 9.094074 us, ub 17.47765 us, ci 0.950 + +benchmarking utf8 + renderTableD maxiTable +mean: 909.5255 us, lb 908.0049 us, ub 911.7639 us, ci 0.950 +std dev: 9.434182 us, lb 6.906120 us, ub 15.43223 us, ci 0.950 + +benchmarking utf8-light + renderTable maxiTable +mean: 4.128315 ms, lb 4.121109 ms, ub 4.138436 ms, ci 0.950 +std dev: 42.93755 us, lb 32.58115 us, ub 58.61780 us, ci 0.950 + +benchmarking char8 + renderTableBinB maxiTable +mean: 1.224156 ms, lb 1.222510 ms, ub 1.226101 ms, ci 0.950 +std dev: 9.046150 us, lb 7.568433 us, ub 11.74996 us, ci 0.950 + +benchmarking renderTableTB maxiTable +mean: 954.8066 us, lb 953.6650 us, ub 957.0134 us, ci 0.950 +std dev: 7.763098 us, lb 5.072194 us, ub 14.09216 us, ci 0.950 + +benchmarking utf8 + renderTableTB maxiTable +mean: 1.095913 ms, lb 1.094811 ms, ub 1.098280 ms, ci 0.950 +std dev: 7.865781 us, lb 4.189907 us, ub 15.24606 us, ci 0.950 + +benchmarking utf8 + renderTableB maxiTable +mean: 818.0223 us, lb 816.5118 us, ub 819.9397 us, ci 0.950 +std dev: 8.603917 us, lb 6.764347 us, ub 12.29236 us, ci 0.950 + +benchmarking utf8 + renderTableBE maxiTable +mean: 646.5248 us, lb 645.3735 us, ub 648.2405 us, ci 0.950 +std dev: 7.147889 us, lb 5.222494 us, ub 11.82482 us, ci 0.950 + +-} + + + +{- Conclusion: + ------------- + + * Whenever generating a sequence of bytes: use the 'Builder' type + + => chunks can always be kept large; impossible when exporting only + a strict/lazy bytestring interface. + + => filtering/mapping lazy bytestrings now automatically defragments + the output and guarantees a large chunk size. + + + * Status of work: API complete, documentation needs more reviewing. + + + * Bounded encodings: safely exploiting low-level optimizations + + => a performance advantage on other outputstream-libraries? + + + --------------- + - Questions ? - + --------------- + +-} + + + + +{- Implementation outline: + ------------------------ + +data BufferRange = BufferRange {-# UNPACK #-} !(Ptr Word8) -- First byte of range + {-# UNPACK #-} !(Ptr Word8) -- First byte /after/ range + +newtype BuildStep a = + BuildStep { runBuildStep :: BufferRange -> IO (BuildSignal a) } + +data BuildSignal a = + Done !(Ptr Word8) -- next free byte in current buffer + a -- return value + | BufferFull + !Int -- minimal size of next buffer + !(Ptr Word8) -- next free byte in current buffer + !(BuildStep a) -- continuation to call on next buffer + | InsertByteString + !(Ptr Word8) -- next free byte in current buffer + !S.ByteString -- bytestring to insert directly + !(BuildStep a) -- continuation to call on next buffer + + +-- | A "difference list" of build-steps. +newtype Builder = Builder (forall r. BuildStep r -> BuildStep r) + + +-- | The corresponding "Writer" monad. +newtype Put a = Put { unPut :: forall r. (a -> BuildStep r) -> BuildStep r } + + +-} diff --git a/bench/BenchCount.hs b/bench/BenchCount.hs new file mode 100644 --- /dev/null +++ b/bench/BenchCount.hs @@ -0,0 +1,29 @@ +-- | +-- Copyright : (c) 2021 Georg Rudoy +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Georg Rudoy <0xd34df00d+github@gmail.com> +-- +-- Benchmark count + +module BenchCount (benchCount) where + +import Test.Tasty.Bench +import qualified Data.ByteString.Char8 as B + +benchCount :: Benchmark +benchCount = bgroup "Count" + [ bgroup "no matches, same char" $ mkBenches (1 : commonSizes) (\s -> B.replicate s 'b') + , bgroup "no matches, different chars" $ mkBenches commonSizes (\s -> genCyclic 10 s 'b') + , bgroup "some matches, alternating" $ mkBenches commonSizes (\s -> genCyclic 2 s 'a') + , bgroup "some matches, short cycle" $ mkBenches commonSizes (\s -> genCyclic 5 s 'a') + , bgroup "some matches, long cycle" $ mkBenches commonSizes (\s -> genCyclic 10 s 'a') + , bgroup "all matches" $ mkBenches (1 : commonSizes) (\s -> B.replicate s 'a') + ] + where + aboveSimdSwitchThreshold = 1030 -- something above the threshold of 1024 that's divisible by cycle lengths + commonSizes = [ 10, 100, 1000, aboveSimdSwitchThreshold, 10000, 100000, 1000000 ] + mkBenches sizes gen = [ bench (show size ++ " chars long") $ nf (B.count 'a') (gen size) + | size <- sizes + ] + genCyclic cycleLen size from = B.concat $ replicate (size `div` cycleLen) $ B.pack (take cycleLen [from..]) diff --git a/bench/BenchIndices.hs b/bench/BenchIndices.hs new file mode 100644 --- /dev/null +++ b/bench/BenchIndices.hs @@ -0,0 +1,81 @@ +-- | +-- Copyright : (c) 2020 Peter Duchovni +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Peter Duchovni +-- +-- Benchmark elemIndex, findIndex, elemIndices, and findIndices + +module BenchIndices (benchIndices) where + +import Data.Foldable (foldMap) +import Data.Maybe (listToMaybe) +import Data.Monoid +import Data.String +import Test.Tasty.Bench +import Prelude hiding (words, head, tail) +import Data.Word (Word8) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Unsafe as S + + +------------------------------------------------------------------------------ +-- Benchmark +------------------------------------------------------------------------------ + +-- ASCII \n to ensure no typos +nl :: Word8 +nl = 0xa +{-# INLINE nl #-} + +-- non-inlined equality test +nilEq :: Word8 -> Word8 -> Bool +{-# NOINLINE nilEq #-} +nilEq = (==) + +-- lines of 200 letters from a to e, followed by repeated letter f +absurdlong :: S.ByteString +absurdlong = (S.replicate 200 0x61 <> S.singleton nl + <> S.replicate 200 0x62 <> S.singleton nl + <> S.replicate 200 0x63 <> S.singleton nl + <> S.replicate 200 0x64 <> S.singleton nl + <> S.replicate 200 0x65 <> S.singleton nl) + <> S.replicate 999999 0x66 + +benchIndices :: Benchmark +benchIndices = absurdlong `seq` bgroup "Indices" + [ bgroup "ByteString strict first index" $ + [ bench "FindIndices" $ nf (listToMaybe . S.findIndices (== nl)) absurdlong + , bench "ElemIndices" $ nf (listToMaybe . S.elemIndices nl) absurdlong + , bench "FindIndex" $ nf (S.findIndex (== nl)) absurdlong + , bench "ElemIndex" $ nf (S.elemIndex nl) absurdlong + ] + , bgroup "ByteString strict second index" $ + [ bench "FindIndices" $ nf (listToMaybe . drop 1 . S.findIndices (== nl)) absurdlong + , bench "ElemIndices" $ nf (listToMaybe . drop 1 . S.elemIndices nl) absurdlong + , bench "FindIndex" $ nf bench_find_index_second absurdlong + , bench "ElemIndex" $ nf bench_elem_index_second absurdlong + ] + , bgroup "ByteString index equality inlining" $ + [ bench "FindIndices/inlined" $ nf (S.findIndices (== nl)) absurdlong + , bench "FindIndices/non-inlined" $ nf (S.findIndices (nilEq nl)) absurdlong + , bench "FindIndex/inlined" $ nf (S.findIndex (== nl)) absurdlong + , bench "FindIndex/non-inlined" $ nf (S.findIndex (nilEq nl)) absurdlong + ] + ] + +bench_find_index_second :: S.ByteString -> Maybe Int +bench_find_index_second bs = + let isNl = (== nl) + in case S.findIndex isNl bs of + Just !i -> S.findIndex isNl (S.unsafeDrop (i+1) bs) + Nothing -> Nothing +{-# INLINE bench_find_index_second #-} + +bench_elem_index_second :: S.ByteString -> Maybe Int +bench_elem_index_second bs = + case S.elemIndex nl bs of + Just !i -> S.elemIndex nl (S.unsafeDrop (i+1) bs) + Nothing -> Nothing +{-# INLINE bench_elem_index_second #-} diff --git a/bench/BenchReadInt.hs b/bench/BenchReadInt.hs new file mode 100644 --- /dev/null +++ b/bench/BenchReadInt.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Copyright : (c) 2021 Viktor Dukhovni +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Viktor Dukhovni +-- +-- Benchmark readInt and variants, readWord and variants, +-- readInteger and readNatural + +module BenchReadInt (benchReadInt) where + +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Test.Tasty.Bench +import Data.Int +import Data.Word +import Numeric.Natural +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup (Semigroup((<>))) +#endif +import Data.Monoid (mconcat) + +------------------------------------------------------------------------------ +-- Benchmark +------------------------------------------------------------------------------ + +-- Sum space-separated integers in a ByteString. +loopS :: Integral a + => (S.ByteString -> Maybe (a, S.ByteString)) -> S.ByteString -> a +loopS rd = go 0 + where + go !acc !bs = case rd bs of + Just (i, t) -> case S.uncons t of + Just (_, t') -> go (acc + i) t' + Nothing -> acc + i + Nothing -> acc + +-- Sum space-separated integers in a ByteString. +loopL :: Integral a + => (L.ByteString -> Maybe (a, L.ByteString)) -> L.ByteString -> a +loopL rd = go 0 + where + go !acc !bs = case rd bs of + Just (i, t) -> case L.uncons t of + Just (_, t') -> go (acc + i) t' + Nothing -> acc + i + Nothing -> acc + +benchReadInt :: Benchmark +benchReadInt = bgroup "Read Integral" + [ bgroup "Strict" + [ bench "ReadInt" $ nf (loopS S.readInt) intS + , bench "ReadInt8" $ nf (loopS S.readInt8) int8S + , bench "ReadInt16" $ nf (loopS S.readInt16) int16S + , bench "ReadInt32" $ nf (loopS S.readInt32) int32S + , bench "ReadInt64" $ nf (loopS S.readInt64) int64S + , bench "ReadWord" $ nf (loopS S.readWord) wordS + , bench "ReadWord8" $ nf (loopS S.readWord8) word8S + , bench "ReadWord16" $ nf (loopS S.readWord16) word16S + , bench "ReadWord32" $ nf (loopS S.readWord32) word32S + , bench "ReadWord64" $ nf (loopS S.readWord64) word64S + , bench "ReadInteger" $ nf (loopS S.readInteger) bignatS + , bench "ReadNatural" $ nf (loopS S.readNatural) bignatS + , bench "ReadInteger small" $ nf (loopS S.readInteger) intS + , bench "ReadNatural small" $ nf (loopS S.readNatural) wordS + ] + + , bgroup "Lazy" + [ bench "ReadInt" $ nf (loopL L.readInt) intL + , bench "ReadInt8" $ nf (loopL L.readInt8) int8L + , bench "ReadInt16" $ nf (loopL L.readInt16) int16L + , bench "ReadInt32" $ nf (loopL L.readInt32) int32L + , bench "ReadInt64" $ nf (loopL L.readInt64) int64L + , bench "ReadWord" $ nf (loopL L.readWord) wordL + , bench "ReadWord8" $ nf (loopL L.readWord8) word8L + , bench "ReadWord16" $ nf (loopL L.readWord16) word16L + , bench "ReadWord32" $ nf (loopL L.readWord32) word32L + , bench "ReadWord64" $ nf (loopL L.readWord64) word64L + , bench "ReadInteger" $ nf (loopL L.readInteger) bignatL + , bench "ReadNatural" $ nf (loopL L.readNatural) bignatL + , bench "ReadInteger small" $ nf (loopL L.readInteger) intL + , bench "ReadNatural small" $ nf (loopL L.readNatural) wordL + ] + ] + where + mkWordL :: forall a. (Integral a, Bounded a) + => (a -> B.Builder) -> L.ByteString + mkWordL f = B.toLazyByteString b + where b = mconcat [f i <> B.char8 ' ' | i <- [n-255..n]] + n = maxBound @a + mkWordS f = S.toStrict $ mkWordL f + + mkIntL :: forall a. (Integral a, Bounded a) + => (a -> B.Builder) -> L.ByteString + mkIntL f = B.toLazyByteString b + where b = mconcat [f (i + 128) <> B.char8 ' ' | i <- [n-255..n]] + n = maxBound @a + mkIntS f = S.toStrict $ mkIntL f + + wordS, word8S, word16S, word32S, word64S :: S.ByteString + !wordS = mkWordS B.wordDec + !word8S = mkWordS B.word8Dec + !word16S = mkWordS B.word16Dec + !word32S = mkWordS B.word32Dec + !word64S = mkWordS B.word64Dec + + intS, int8S, int16S, int32S, int64S :: S.ByteString + !intS = mkIntS B.intDec + !int8S = mkIntS B.int8Dec + !int16S = mkIntS B.int16Dec + !int32S = mkIntS B.int32Dec + !int64S = mkIntS B.int64Dec + + word8L, word16L, word32L, word64L :: L.ByteString + !wordL = mkWordL B.wordDec + !word8L = mkWordL B.word8Dec + !word16L = mkWordL B.word16Dec + !word32L = mkWordL B.word32Dec + !word64L = mkWordL B.word64Dec + + intL, int8L, int16L, int32L, int64L :: L.ByteString + !intL = mkIntL B.intDec + !int8L = mkIntL B.int8Dec + !int16L = mkIntL B.int16Dec + !int32L = mkIntL B.int32Dec + !int64L = mkIntL B.int64Dec + + bignatL :: L.ByteString + !bignatL = B.toLazyByteString b + where b = mconcat [B.integerDec (powpow i) <> B.char8 ' ' | i <- [0..13]] + powpow :: Word -> Integer + powpow n = 2^(2^n :: Word) + + bignatS :: S.ByteString + !bignatS = S.toStrict bignatL diff --git a/bench/BenchShort.hs b/bench/BenchShort.hs new file mode 100644 --- /dev/null +++ b/bench/BenchShort.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE OverloadedStrings #-} + +module BenchShort (benchShort) where + +import Control.DeepSeq (force) +import Data.Foldable (foldMap) +import Data.Maybe (listToMaybe) +import Data.Monoid +import Data.String +import Test.Tasty.Bench +import Prelude hiding (words, head, tail) + +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as S + +import Data.ByteString.Builder +import Data.ByteString.Builder.Extra (byteStringCopy, + byteStringInsert, + intHost) +import Data.ByteString.Builder.Internal (ensureFree) +import Data.ByteString.Builder.Prim (BoundedPrim, FixedPrim, + (>$<)) +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Builder.Prim.Internal as PI + +import Foreign + +import System.Random + + + +------------------------------------------------------------------------------ +-- Benchmark +------------------------------------------------------------------------------ + +-- input data (NOINLINE to ensure memoization) +---------------------------------------------- + +-- | Few-enough repetitions to avoid making GC too expensive. +nRepl :: Int +nRepl = 10000 + +{-# NOINLINE intData #-} +intData :: [Int] +intData = [1..nRepl] + +{-# NOINLINE byteStringData #-} +byteStringData :: S.ShortByteString +byteStringData = S.pack $ map fromIntegral intData + +{-# NOINLINE loremIpsum #-} +loremIpsum :: S.ShortByteString +loremIpsum = mconcat + [ " Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor" + , "incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis" + , "nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat." + , "Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu" + , "fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in" + , "culpa qui officia deserunt mollit anim id est laborum." + ] + +-- benchmark wrappers +--------------------- + +{-# INLINE benchB' #-} +benchB' :: String -> a -> (a -> ShortByteString) -> Benchmark +benchB' name x b = bench name $ whnf (S.length . b) x + + +-- We use this construction of just looping through @n,n-1,..,1@ to ensure that +-- we measure the speed of the encoding and not the speed of generating the +-- values to be encoded. +{-# INLINE benchIntEncodingB #-} +benchIntEncodingB :: Int -- ^ Maximal 'Int' to write + -> BoundedPrim Int -- ^ 'BoundedPrim' to execute + -> IO () -- ^ 'IO' action to benchmark +benchIntEncodingB n0 w + | n0 <= 0 = return () + | otherwise = do + fpbuf <- mallocForeignPtrBytes (n0 * PI.sizeBound w) + withForeignPtr fpbuf (loop n0) >> return () + where + loop !n !op + | n <= 0 = return op + | otherwise = PI.runB w n op >>= loop (n - 1) + + +-- Helpers +------------- + +hashInt :: Int -> Int +hashInt x = iterate step x !! 10 + where + step a = e + where b = (a `xor` 61) `xor` (a `shiftR` 16) + c = b + (b `shiftL` 3) + d = c `xor` (c `shiftR` 4) + e = d * 0x27d4eb2d + f = e `xor` (e `shiftR` 15) + +w :: Int -> Word8 +w = fromIntegral + +hashWord8 :: Word8 -> Word8 +hashWord8 = fromIntegral . hashInt . fromIntegral + +foldInputs' :: [[Word8]] +foldInputs' = force (S.unpack <$> foldInputs) + +foldInputs :: [S.ShortByteString] +foldInputs = map (\k -> S.pack $ if k <= 6 then take (2 ^ k) [32..95] else concat (replicate (2 ^ (k - 6)) [32..95])) [0..16] + +largeTraversalInput :: S.ShortByteString +largeTraversalInput = S.concat (replicate 10 byteStringData) + +smallTraversalInput :: S.ShortByteString +smallTraversalInput = "The quick brown fox" + +zeroes :: S.ShortByteString +zeroes = S.replicate 10000 0 + +partitionStrict p = nf (S.partition p) . randomStrict $ mkStdGen 98423098 + where randomStrict = fst . S.unfoldrN 10000 (Just . random) + +-- ASCII \n to ensure no typos +nl :: Word8 +nl = 0xa +{-# INLINE nl #-} + +-- non-inlined equality test +nilEq :: Word8 -> Word8 -> Bool +{-# NOINLINE nilEq #-} +nilEq = (==) + +-- lines of 200 letters from a to e, followed by repeated letter f +absurdlong :: S.ShortByteString +absurdlong = (S.replicate 200 0x61 <> S.singleton nl + <> S.replicate 200 0x62 <> S.singleton nl + <> S.replicate 200 0x63 <> S.singleton nl + <> S.replicate 200 0x64 <> S.singleton nl + <> S.replicate 200 0x65 <> S.singleton nl) + <> S.replicate 999999 0x66 + +bench_find_index_second :: ShortByteString -> Maybe Int +bench_find_index_second bs = + let isNl = (== nl) + in case S.findIndex isNl bs of + Just !i -> S.findIndex isNl (S.drop (i+1) bs) + Nothing -> Nothing +{-# INLINE bench_find_index_second #-} + +bench_elem_index_second :: ShortByteString -> Maybe Int +bench_elem_index_second bs = + case S.elemIndex nl bs of + Just !i -> S.elemIndex nl (S.drop (i+1) bs) + Nothing -> Nothing +{-# INLINE bench_elem_index_second #-} + + + +-- benchmarks +------------- + +benchShort :: Benchmark +benchShort = absurdlong `seq` bgroup "ShortByteString" + [ bgroup "Small payload" + [ benchB' "mempty" () (const mempty) + , benchB' "UTF-8 String (naive)" "hello world\0" fromString + , benchB' "String (naive)" "hello world!" fromString + ] + , bgroup "intercalate" + [ bench "intercalate (large)" $ whnf (S.intercalate $ " and also ") (replicate 300 "expression") + , bench "intercalate (small)" $ whnf (S.intercalate "&") (replicate 30 "foo") + , bench "intercalate (tiny)" $ whnf (S.intercalate "&") (["foo", "bar", "baz"]) + ] + , bgroup "partition" + [ + bgroup "strict" + [ + bench "mostlyTrueFast" $ partitionStrict (< (w 225)) + , bench "mostlyFalseFast" $ partitionStrict (< (w 10)) + , bench "balancedFast" $ partitionStrict (< (w 128)) + + , bench "mostlyTrueSlow" $ partitionStrict (\x -> hashWord8 x < w 225) + , bench "mostlyFalseSlow" $ partitionStrict (\x -> hashWord8 x < w 10) + , bench "balancedSlow" $ partitionStrict (\x -> hashWord8 x < w 128) + ] + ] + , bgroup "folds" + [ bgroup "strict" + [ bgroup "foldl" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldl (\acc x -> acc + fromIntegral x) (0 :: Int)) s) foldInputs + , bgroup "foldl'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldl' (\acc x -> acc + fromIntegral x) (0 :: Int)) s) foldInputs + , bgroup "foldr" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldr (\x acc -> fromIntegral x + acc) (0 :: Int)) s) foldInputs + , bgroup "foldr'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldr' (\x acc -> fromIntegral x + acc) (0 :: Int)) s) foldInputs + , bgroup "foldr1'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldr1' (\x acc -> fromIntegral x + acc)) s) foldInputs + , bgroup "unfoldrN" $ map (\s -> bench (show $ S.length s) $ + nf (S.unfoldrN (S.length s) (\a -> Just (a, a + 1))) 0) foldInputs + , bgroup "filter" $ map (\s -> bench (show $ S.length s) $ + nf (S.filter odd) s) foldInputs + ] + ] + , bgroup "findIndexOrLength" + [ bench "takeWhile" $ nf (S.takeWhile even) zeroes + , bench "dropWhile" $ nf (S.dropWhile even) zeroes + , bench "break" $ nf (S.break odd) zeroes + ] + , bgroup "findIndex_" + [ bench "findIndices" $ nf (sum . S.findIndices (\x -> x == 129 || x == 72)) byteStringData + , bench "find" $ nf (S.find (>= 198)) byteStringData + ] + , bgroup "traversals" + [ bench "map (+1) large" $ nf (S.map (+ 1)) largeTraversalInput + , bench "map (+1) small" $ nf (S.map (+ 1)) smallTraversalInput + ] + , bgroup "ShortByteString strict first index" $ + [ bench "FindIndices" $ nf (listToMaybe . S.findIndices (== nl)) absurdlong + , bench "ElemIndices" $ nf (listToMaybe . S.elemIndices nl) absurdlong + , bench "FindIndex" $ nf (S.findIndex (== nl)) absurdlong + , bench "ElemIndex" $ nf (S.elemIndex nl) absurdlong + ] + , bgroup "ShortByteString strict second index" $ + [ bench "FindIndices" $ nf (listToMaybe . drop 1 . S.findIndices (== nl)) absurdlong + , bench "ElemIndices" $ nf (listToMaybe . drop 1 . S.elemIndices nl) absurdlong + , bench "FindIndex" $ nf bench_find_index_second absurdlong + , bench "ElemIndex" $ nf bench_elem_index_second absurdlong + ] + , bgroup "ShortByteString index equality inlining" $ + [ bench "FindIndices/inlined" $ nf (S.findIndices (== nl)) absurdlong + , bench "FindIndices/non-inlined" $ nf (S.findIndices (nilEq nl)) absurdlong + , bench "FindIndex/inlined" $ nf (S.findIndex (== nl)) absurdlong + , bench "FindIndex/non-inlined" $ nf (S.findIndex (nilEq nl)) absurdlong + ] + , bgroup "ShortByteString conversions" $ + [ bgroup "unpack" $ map (\s -> bench (show $ S.length s) $ + nf (\x -> S.unpack x) s) foldInputs + , bgroup "pack" $ map (\s -> bench (show $ length s) $ + nf S.pack s) foldInputs' + , bench "unpack and get last element" $ nf (\x -> last . S.unpack $ x) absurdlong + , bench "unpack and get first 120 elements" $ nf (\x -> take 120 . S.unpack $ x) absurdlong + ] + ] diff --git a/bench/BoundsCheckFusion.hs b/bench/BoundsCheckFusion.hs deleted file mode 100644 --- a/bench/BoundsCheckFusion.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE PackageImports, ScopedTypeVariables, BangPatterns #-} --- | --- Copyright : (c) 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : tested on GHC only --- --- Benchmark that the bounds checks fuse. -module Main (main) where - -import Prelude hiding (words) -import Criterion.Main -import Data.Monoid -import Data.Foldable (foldMap) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - -import Data.ByteString.Lazy.Builder -import Data.ByteString.Lazy.Builder.Extras -import Data.ByteString.Lazy.Builder.BasicEncoding - ( FixedEncoding, BoundedEncoding, (>$<), (>*<) ) -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E -import qualified Data.ByteString.Lazy.Builder.Internal as I -import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Internal as I - -import Foreign - ------------------------------------------------------------------------------- --- Benchmark support ------------------------------------------------------------------------------- - -countToZero :: Int -> Maybe (Int, Int) -countToZero 0 = Nothing -countToZero n = Just (n, n - 1) - - ------------------------------------------------------------------------------- --- Benchmark ------------------------------------------------------------------------------- - --- input data (NOINLINE to ensure memoization) ----------------------------------------------- - --- | Few-enough repetitions to avoid making GC too expensive. -nRepl :: Int -nRepl = 10000 - -{-# NOINLINE intData #-} -intData :: [Int] -intData = [1..nRepl] - --- benchmark wrappers ---------------------- - -{-# INLINE benchB #-} -benchB :: String -> a -> (a -> Builder) -> Benchmark -benchB name x b = - bench (name ++" (" ++ show nRepl ++ ")") $ - whnf (L.length . toLazyByteString . b) x - -{-# INLINE benchBInts #-} -benchBInts :: String -> ([Int] -> Builder) -> Benchmark -benchBInts name = benchB name intData - - --- benchmarks -------------- - -sanityCheckInfo :: [String] -sanityCheckInfo = - [ "Sanity checks:" - , " lengths of input data: " ++ show - [ length intData ] - ] - -main :: IO () -main = do - mapM_ putStrLn sanityCheckInfo - putStrLn "" - Criterion.Main.defaultMain - [ bgroup "Data.ByteString.Lazy.Builder" - [ -- benchBInts "foldMap intHost" $ - -- foldMap (intHost . fromIntegral) - -{- - benchBInts "mapM_ (\\x -> intHost x `mappend` intHost x)" $ - foldMap ((\x -> intHost x `mappend` intHost x) - - , benchBInts "foldMap (\\x -> intHost x `mappend` intHost x)" $ - foldMap (\x -> intHost x `mappend` intHost x) --} - - benchBInts "foldMap (left-assoc)" $ - foldMap (\x -> (stringUtf8 "s" `mappend` intHost x) `mappend` intHost x) - - , benchBInts "foldMap (right-assoc)" $ - foldMap (\x -> intHost x `mappend` (intHost x `mappend` stringUtf8 "s")) - - , benchBInts "foldMap [manually fused, left-assoc]" $ - foldMap (\x -> stringUtf8 "s" `mappend` E.encodeWithB (E.fromF $ E.intHost >*< E.intHost) (x, x)) - - , benchBInts "foldMap [manually fused, right-assoc]" $ - foldMap (\x -> E.encodeWithB (E.fromF $ E.intHost >*< E.intHost) (x, x) `mappend` stringUtf8 "s") - - -- , benchBInts "encodeListWithF intHost" $ - -- E.encodeListWithF (fromIntegral >$< E.intHost) - ] - ] - -{-# RULES - -"append/encodeWithB" forall w1 w2 x1 x2. - I.append (E.encodeWithB w1 x1) (E.encodeWithB w2 x2) - = E.encodeWithB (E.pairB w1 w2) (x1, x2) - -"append/encodeWithB/assoc_r" forall w1 w2 x1 x2 b. - I.append (E.encodeWithB w1 x1) (I.append (E.encodeWithB w2 x2) b) - = I.append (E.encodeWithB (E.pairB w1 w2) (x1, x2)) b - -"append/encodeWithB/assoc_l" forall w1 w2 x1 x2 b. - I.append (I.append b (E.encodeWithB w1 x1)) (E.encodeWithB w2 x2) - = I.append b (E.encodeWithB (E.pairB w1 w2) (x1, x2)) - #-} - diff --git a/bytestring.cabal b/bytestring.cabal --- a/bytestring.cabal +++ b/bytestring.cabal @@ -1,5 +1,7 @@ +Cabal-Version: 2.2 + Name: bytestring -Version: 0.10.0.2 +Version: 0.12.2.0 Synopsis: Fast, compact, strict and lazy byte strings with a list interface Description: An efficient compact, immutable byte string type (both strict and lazy) @@ -7,7 +9,7 @@ . The 'ByteString' type represents sequences of bytes or 8-bit characters. It is suitable for high performance use, both in terms of large data - quantities, or high speed requirements. The 'ByteStrin'g functions follow + quantities, or high speed requirements. The 'ByteString' functions follow the same style as Haskell\'s ordinary lists, so it is easy to convert code from using 'String' to 'ByteString'. . @@ -28,6 +30,11 @@ in an ad-hoc way by repeated concatenation. This is ideal for fast serialisation or pretty printing. . + There is also a 'ShortByteString' type which has a lower memory overhead + and can be converted to or from a 'ByteString'. It is suitable for keeping + many short strings in memory, especially long-term, without incurring any + possible heap fragmentation costs. + . 'ByteString's are not designed for Unicode. For Unicode strings you should use the 'Text' type from the @text@ package. . @@ -36,182 +43,211 @@ . > import qualified Data.ByteString as BS -License: BSD3 +License: BSD-3-Clause License-file: LICENSE Category: Data Copyright: Copyright (c) Don Stewart 2005-2009, - (c) Duncan Coutts 2006-2012, + (c) Duncan Coutts 2006-2015, (c) David Roundy 2003-2005, (c) Jasper Van der Jeugt 2010, - (c) Simon Meier 2010-2011. + (c) Simon Meier 2010-2013. Author: Don Stewart, Duncan Coutts -Maintainer: Don Stewart , - Duncan Coutts -Bug-reports: dons00@gmail.com, - duncan@community.haskell.org -Tested-With: GHC==7.6.1, GHC==7.4.1, GHC==7.0.4, GHC==6.12.3 +Maintainer: Haskell Bytestring Team , Core Libraries Committee +Homepage: https://github.com/haskell/bytestring +Bug-reports: https://github.com/haskell/bytestring/issues +Tested-With: GHC==9.10.1, + GHC==9.8.2, + GHC==9.6.5, + GHC==9.4.8, + GHC==9.2.8, + GHC==9.0.2, + GHC==8.10.7, + GHC==8.8.4, + GHC==8.6.5, + GHC==8.4.4 Build-Type: Simple -Cabal-Version: >= 1.8 -extra-source-files: README TODO +extra-source-files: README.md Changelog.md include/bytestring-cpp-macros.h +Flag pure-haskell + description: Don't use bytestring's standard C routines + + When this flag is true, bytestring will use pure Haskell variants (no C FFI) + of the internal functions. This is not recommended except in use cases that + cannot (or do not) depend on C, such as with GHC's JavaScript backend. + + default: False + manual: True + source-repository head - type: darcs - location: http://darcs.haskell.org/bytestring/ + type: git + location: https://github.com/haskell/bytestring -library - build-depends: base >= 4.2 && < 5, ghc-prim, deepseq - exposed-modules: Data.ByteString - Data.ByteString.Char8 - Data.ByteString.Unsafe - Data.ByteString.Internal - Data.ByteString.Lazy - Data.ByteString.Lazy.Char8 - Data.ByteString.Lazy.Internal +common language + default-language: Haskell2010 + default-extensions: + BangPatterns + DeriveDataTypeable + DeriveGeneric + DeriveLift + FlexibleContexts + FlexibleInstances + LambdaCase + MagicHash + MultiWayIf + NamedFieldPuns + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeOperators + UnboxedTuples - Data.ByteString.Lazy.Builder - Data.ByteString.Lazy.Builder.Extras - Data.ByteString.Lazy.Builder.ASCII +library + import: language + build-depends: base >= 4.11 && < 5, ghc-prim, deepseq, template-haskell - other-modules: - -- these three modules should be exposed in a future - -- release once we're confident the API is stable. - Data.ByteString.Lazy.Builder.Internal - Data.ByteString.Lazy.Builder.BasicEncoding - Data.ByteString.Lazy.Builder.BasicEncoding.Extras - Data.ByteString.Lazy.Builder.BasicEncoding.Internal + if impl(ghc < 9.4) + build-depends: data-array-byte >= 0.1 && < 0.2 - Data.ByteString.Lazy.Builder.BasicEncoding.Binary - Data.ByteString.Lazy.Builder.BasicEncoding.ASCII - Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Floating - Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts - Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Base16 + exposed-modules: Data.ByteString + Data.ByteString.Char8 + Data.ByteString.Unsafe + Data.ByteString.Internal + Data.ByteString.Lazy + Data.ByteString.Lazy.Char8 + Data.ByteString.Lazy.Internal + Data.ByteString.Short + Data.ByteString.Short.Internal - extensions: CPP, - ForeignFunctionInterface, - BangPatterns - UnliftedFFITypes, - MagicHash, - UnboxedTuples, - DeriveDataTypeable - ScopedTypeVariables - Rank2Types - NamedFieldPuns + Data.ByteString.Builder + Data.ByteString.Builder.Extra + Data.ByteString.Builder.Prim + Data.ByteString.Builder.RealFloat - ghc-options: -Wall - -O2 - -fmax-simplifier-iterations=10 - -fdicts-cheap - -fspec-constr-count=6 + -- perhaps only exposed temporarily + Data.ByteString.Builder.Internal + Data.ByteString.Builder.Prim.Internal + other-modules: Data.ByteString.Builder.ASCII + Data.ByteString.Builder.Prim.ASCII + Data.ByteString.Builder.Prim.Binary + Data.ByteString.Builder.Prim.Internal.Base16 + Data.ByteString.Builder.Prim.Internal.Floating + Data.ByteString.Builder.RealFloat.F2S + Data.ByteString.Builder.RealFloat.D2S + Data.ByteString.Builder.RealFloat.Internal + Data.ByteString.Builder.RealFloat.TableGenerator + Data.ByteString.Internal.Type + Data.ByteString.Lazy.ReadInt + Data.ByteString.Lazy.ReadNat + Data.ByteString.ReadInt + Data.ByteString.ReadNat + Data.ByteString.Utils.ByteOrder + Data.ByteString.Utils.UnalignedAccess - c-sources: cbits/fpstring.c - cbits/itoa.c - include-dirs: include - includes: fpstring.h - install-includes: fpstring.h + ghc-options: -Wall -fwarn-tabs -Wincomplete-uni-patterns + -optP-Wall -optP-Werror=undef + -O2 + -fmax-simplifier-iterations=10 + -fdicts-cheap + -fspec-constr-count=6 + if arch(javascript) || flag(pure-haskell) + cpp-options: -DPURE_HASKELL=1 + other-modules: Data.ByteString.Internal.Pure + default-extensions: NoForeignFunctionInterface + -- Pure Haskell implementation only implemented for recent GHCs/base + build-depends: base >= 4.18 && < 5 + else + cpp-options: -DPURE_HASKELL=0 --- QC properties, with GHC RULES disabled -test-suite prop-compiled - type: exitcode-stdio-1.0 - main-is: Properties.hs - other-modules: Rules - QuickCheckUtils - TestFramework - hs-source-dirs: . tests - build-depends: base, ghc-prim, deepseq, random, directory, - QuickCheck >= 2.3 && < 3 - c-sources: cbits/fpstring.c - include-dirs: include - ghc-options: -fwarn-unused-binds - -fno-enable-rewrite-rules - extensions: BangPatterns - UnliftedFFITypes, - MagicHash, - UnboxedTuples, - DeriveDataTypeable - ScopedTypeVariables - NamedFieldPuns + c-sources: cbits/fpstring.c + cbits/itoa.c + cbits/shortbytestring.c + cbits/aligned-static-hs-data.c -test-suite test-builder - type: exitcode-stdio-1.0 - hs-source-dirs: . tests tests/builder - main-is: TestSuite.hs - other-modules: Data.ByteString.Lazy.Builder.Tests - Data.ByteString.Lazy.Builder.BasicEncoding.Tests - Data.ByteString.Lazy.Builder.BasicEncoding.TestUtils - Data.ByteString.Lazy.Builder.BasicEncoding.Extras - TestFramework + if (arch(aarch64)) + c-sources: cbits/aarch64/is-valid-utf8.c + else + c-sources: cbits/is-valid-utf8.c - build-depends: base, ghc-prim, - deepseq, - QuickCheck >= 2.4 && < 3, - byteorder == 1.0.*, - dlist == 0.5.*, - directory, - mtl >= 2.0 && < 2.2 + -- DNDEBUG disables asserts in cbits/ + cc-options: -std=c11 -DNDEBUG=1 + -fno-strict-aliasing + -Werror=undef - ghc-options: -Wall -fwarn-tabs + -- No need to link to libgcc on ghc-9.4 and later which uses a clang-based + -- toolchain. + if os(windows) && impl(ghc < 9.3) + extra-libraries: gcc - extensions: CPP, ForeignFunctionInterface - UnliftedFFITypes, - MagicHash, - UnboxedTuples, - DeriveDataTypeable - ScopedTypeVariables - Rank2Types - BangPatterns - NamedFieldPuns + if arch(aarch64) + -- The libffi in Apple's darwin toolchain doesn't + -- play nice with -Wundef. Recent GHCs work around this. + -- See also https://github.com/haskell/bytestring/issues/665 + -- and https://gitlab.haskell.org/ghc/ghc/-/issues/23568 + build-depends: base (>= 4.17.2 && < 4.18) || >= 4.18.1 - c-sources: cbits/fpstring.c - cbits/itoa.c - include-dirs: include - includes: fpstring.h - install-includes: fpstring.h + include-dirs: include + install-includes: fpstring.h + bytestring-cpp-macros.h -benchmark bench-builder-all +test-suite bytestring-tests + import: language type: exitcode-stdio-1.0 - hs-source-dirs: . bench - main-is: BenchAll.hs - build-depends: base, deepseq, ghc-prim, - criterion - c-sources: cbits/fpstring.c - cbits/itoa.c - include-dirs: include - ghc-options: -O2 - -fmax-simplifier-iterations=10 - -fdicts-cheap - -fspec-constr-count=6 + main-is: Main.hs + other-modules: Builder + Data.ByteString.Builder.Prim.TestUtils + Data.ByteString.Builder.Prim.Tests + Data.ByteString.Builder.Tests + IsValidUtf8 + LazyHClose + Lift + Properties + Properties.ByteString + Properties.ByteStringChar8 + Properties.ByteStringLazy + Properties.ByteStringLazyChar8 + Properties.ShortByteString + QuickCheckUtils + hs-source-dirs: tests, + tests/builder + build-depends: base, + bytestring, + deepseq, + QuickCheck, + tasty, + tasty-quickcheck >= 0.8.1, + template-haskell, + transformers >= 0.3, + syb -benchmark bench-builder-boundscheck + ghc-options: -fwarn-unused-binds + -rtsopts + if !arch(wasm32) + ghc-options: -threaded + +benchmark bytestring-bench + import: language + main-is: BenchAll.hs + other-modules: BenchBoundsCheckFusion + BenchCount + BenchCSV + BenchIndices + BenchReadInt + BenchShort type: exitcode-stdio-1.0 - hs-source-dirs: . bench - main-is: BoundsCheckFusion.hs - build-depends: base, deepseq, ghc-prim, - criterion - c-sources: cbits/fpstring.c - cbits/itoa.c - include-dirs: include - ghc-options: -O2 - -fmax-simplifier-iterations=10 - -fdicts-cheap - -fspec-constr-count=6 + hs-source-dirs: bench --- Sadly we cannot use benchmark bench-builder-csv currently because it --- depends on both text and binary, which both depend on bytestring --- which gives cabal fits about cyclic dependencies. --- type: exitcode-stdio-1.0 --- hs-source-dirs: . bench --- main-is: CSV.hs --- build-depends: base, deepseq, ghc-prim, --- text, binary, --- criterion --- c-sources: cbits/fpstring.c --- cbits/itoa.c --- include-dirs: include --- ghc-options: -O2 --- -fmax-simplifier-iterations=10 --- -fdicts-cheap --- -fspec-constr-count=6 + ghc-options: -O2 "-with-rtsopts=-A32m" + if impl(ghc >= 8.6) + ghc-options: -fproc-alignment=64 + build-depends: base, + bytestring, + deepseq, + tasty-bench, + random diff --git a/cbits/aarch64/is-valid-utf8.c b/cbits/aarch64/is-valid-utf8.c new file mode 100644 --- /dev/null +++ b/cbits/aarch64/is-valid-utf8.c @@ -0,0 +1,284 @@ +/* +Copyright (c) Koz Ross 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. +*/ +#pragma GCC push_options +#pragma GCC optimize("-O2") +#include +#include +#include +#include + +// Fallback (for tails). +static inline int is_valid_utf8_fallback(uint8_t const *const src, + size_t const len) { + uint8_t const *ptr = (uint8_t const *)src; + // This is 'one past the end' to make loop termination and bounds checks + // easier. + uint8_t const *const end = ptr + len; + while (ptr < end) { + uint8_t const byte = *ptr; + // Check if the byte is ASCII. + if (byte <= 0x7F) { + ptr++; + } + // Check for a valid 2-byte sequence. + // + // We use a signed comparison to avoid an extra comparison with 0x80, since + // _signed_ 0x80 is -128. + else if (ptr + 1 < end && byte >= 0xC2 && byte <= 0xDF && + ((int8_t) * (ptr + 1)) <= (int8_t)0xBF) { + ptr += 2; + } + // Check for a valid 3-byte sequence. + else if (ptr + 2 < end && byte >= 0xE0 && byte <= 0xEF) { + uint8_t const byte2 = *(ptr + 1); + bool byte2_valid = (int8_t)byte2 <= (int8_t)0xBF; + bool byte3_valid = ((int8_t) * (ptr + 2)) <= (int8_t)0xBF; + if (byte2_valid && byte3_valid && + // E0, A0..BF, 80..BF + ((byte == 0xE0 && byte2 >= 0xA0) || + // E1..EC, 80..BF, 80..BF + (byte >= 0xE1 && byte <= 0xEC) || + // ED, 80..9F, 80..BF + (byte == 0xED && byte2 <= 0x9F) || + // EE..EF, 80..BF, 80..BF + (byte >= 0xEE && byte <= 0xEF))) { + ptr += 3; + } else { + return 0; + } + } + // Check for a valid 4-byte sequence. + else if (ptr + 3 < end) { + uint8_t const byte2 = *(ptr + 1); + bool byte2_valid = (int8_t)byte2 <= (int8_t)0xBF; + bool byte3_valid = ((int8_t) * (ptr + 2)) <= (int8_t)0xBF; + bool byte4_valid = ((int8_t) * (ptr + 3)) <= (int8_t)0xBF; + if (byte2_valid && byte3_valid && byte4_valid && + // F0, 90..BF, 80..BF, 80..BF + ((byte == 0xF0 && byte2 >= 0x90) || + // F1..F3, 80..BF, 80..BF, 80..BF + (byte >= 0xF1 && byte <= 0xF3) || + // F4, 80..8F, 80..BF, 80..BF + (byte == 0xF4 && byte2 <= 0x8F))) { + ptr += 4; + } else { + return 0; + } + } + // Otherwise, invalid. + else { + return 0; + } + } + // If we got this far, we're valid. + return 1; +} + +static uint8_t const first_len_lookup[16] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 2, 3, +}; + +static uint8_t const first_range_lookup[16] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 8, 8, +}; + +static uint8_t const range_min_lookup[16] = { + 0x00, 0x80, 0x80, 0x80, 0xA0, 0x80, 0x90, 0x80, + 0xC2, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, +}; + +static uint8_t const range_max_lookup[16] = { + 0x7F, 0xBF, 0xBF, 0xBF, 0xBF, 0x9F, 0xBF, 0x8F, + 0xF4, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, +}; + +static uint8_t const range_adjust_lookup[32] = { + 2, 3, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 0, 0, +}; + +static bool is_ascii(uint8x16_t const *const inputs, + uint8x16_t const prev_first_len) { + // Check if we have ASCII, and also that we don't have to treat the prior + // block as special. + // First, verify that we didn't see any non-ASCII bytes in the first half of + // the stride. + uint8x16_t const first_half_clean = vorrq_u8(inputs[0], inputs[1]); + // Then we do the same for the second half of the stride. + uint8x16_t const second_half_clean = vorrq_u8(inputs[2], inputs[3]); + // Check cleanliness of the entire stride. + uint8x16_t const stride_clean = vorrq_u8(first_half_clean, second_half_clean); + // Leave only the high-order set bits. + uint8x16_t const masked = vandq_u8(stride_clean, vdupq_n_u8(0x80)); + // Finally, check that we didn't have any leftover marker bytes in the + // previous block: these are indicated by non-zeroes in prev_first_len. In + // order to trigger a failure, we have to have non-zeroes set in the high bit + // of the lane: we do this by doing a greater-than comparison with a block of + // zeroes. + uint8x16_t const no_prior_dirt = vcgtq_u8(prev_first_len, vdupq_n_u8(0x00)); + // Check for all-zero. + uint64x2_t const result = + vreinterpretq_u64_u8(vorrq_u8(masked, no_prior_dirt)); + return !(vgetq_lane_u64(result, 0) || vgetq_lane_u64(result, 1)); +} + +static void +check_block_neon(uint8x16_t const prev_input, uint8x16_t const prev_first_len, + uint8x16_t *errors, uint8x16_t const first_range_tbl, + uint8x16_t const range_min_tbl, uint8x16_t const range_max_tbl, + uint8x16x2_t const range_adjust_tbl, uint8x16_t const all_ones, + uint8x16_t const all_twos, uint8x16_t const all_e0s, + uint8x16_t const input, uint8x16_t const first_len) { + // Get the high 4-bits of the input. + uint8x16_t const high_nibbles = vshrq_n_u8(input, 4); + // Set range index to 8 for bytes in [C0, FF] by lookup (first byte). + uint8x16_t range = vqtbl1q_u8(first_range_tbl, high_nibbles); + // Reduce the range index based on first_len (second byte). + // This is 0 for [00, 7F], 1 for [C0, DF], 2 for [E0, EF], 3 for [F0, FF]. + range = vorrq_u8(range, vextq_u8(prev_first_len, first_len, 15)); + uint8x16_t tmp[2]; + // Set range index to the saturation of (first_len - 1) (third byte). + // This is 0 for [00, 7F], 0 for [C0, DF], 1 for [E0, EF], 2 for [F0, FF]. + tmp[0] = vextq_u8(prev_first_len, first_len, 14); + tmp[0] = vqsubq_u8(tmp[0], all_ones); + range = vorrq_u8(range, tmp[0]); + // Set range index to the saturation of (first_len - 2) (fourth byte). + // This is 0 for [00, 7F], 0 for [C0, DF], 0 for [E0, EF] and 1 for [F0, FF]. + // This is 'split apart' for speed, as we're not as register-starved as on + // x86. + tmp[1] = vextq_u8(prev_first_len, first_len, 13); + tmp[1] = vqsubq_u8(tmp[1], all_twos); + range = vorrq_u8(range, tmp[1]); + // At this stage, we have calculated range indices correctly, except for + // special cases for first bytes (E0, ED, F0, F4). We repair this to avoid + // missing in the range table. + uint8x16_t const shift1 = vextq_u8(prev_input, input, 15); + uint8x16_t const pos = vsubq_u8(shift1, all_e0s); + range = vaddq_u8(range, vqtbl2q_u8(range_adjust_tbl, pos)); + // We can now load minimum and maximum values from our tables based on the + // calculated indices. + uint8x16_t const minv = vqtbl1q_u8(range_min_tbl, range); + uint8x16_t const maxv = vqtbl1q_u8(range_max_tbl, range); + // Accumulate errors, if any. + errors[0] = vorrq_u8(errors[0], vcltq_u8(input, minv)); + errors[1] = vorrq_u8(errors[1], vcgtq_u8(input, maxv)); +} + +int bytestring_is_valid_utf8(uint8_t const *const src, size_t const len) { + if (len == 0) { + return 1; + } + // We step 64 bytes at a time. + size_t const big_strides = len / 64; + size_t const remaining = len % 64; + uint8_t const *ptr = (uint8_t const *)src; + // Tracking state + uint8x16_t prev_input = vdupq_n_u8(0); + uint8x16_t prev_first_len = vdupq_n_u8(0); + uint8x16_t errors[2] = { + vdupq_n_u8(0), + vdupq_n_u8(0), + }; + // Load our lookup tables. + uint8x16_t const first_len_tbl = vld1q_u8(first_len_lookup); + uint8x16_t const first_range_tbl = vld1q_u8(first_range_lookup); + uint8x16_t const range_min_tbl = vld1q_u8(range_min_lookup); + uint8x16_t const range_max_tbl = vld1q_u8(range_max_lookup); + uint8x16x2_t const range_adjust_tbl = vld2q_u8(range_adjust_lookup); + // Useful constants. + uint8x16_t const all_ones = vdupq_n_u8(1); + uint8x16_t const all_twos = vdupq_n_u8(2); + uint8x16_t const all_e0s = vdupq_n_u8(0xE0); + for (size_t i = 0; i < big_strides; i++) { + // Load 64 bytes + uint8x16_t const inputs[4] = {vld1q_u8(ptr), vld1q_u8(ptr + 16), + vld1q_u8(ptr + 32), vld1q_u8(ptr + 48)}; + // Check if we have ASCII + if (is_ascii(inputs, prev_first_len)) { + // Prev_first_len cheaply. + prev_first_len = vqtbl1q_u8(first_len_tbl, vshrq_n_u8(inputs[3], 4)); + } else { + uint8x16_t first_len = + vqtbl1q_u8(first_len_tbl, vshrq_n_u8(inputs[0], 4)); + check_block_neon(prev_input, prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, range_adjust_tbl, all_ones, + all_twos, all_e0s, inputs[0], first_len); + prev_first_len = first_len; + first_len = vqtbl1q_u8(first_len_tbl, vshrq_n_u8(inputs[1], 4)); + check_block_neon(inputs[0], prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, range_adjust_tbl, all_ones, + all_twos, all_e0s, inputs[1], first_len); + prev_first_len = first_len; + first_len = vqtbl1q_u8(first_len_tbl, vshrq_n_u8(inputs[2], 4)); + check_block_neon(inputs[1], prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, range_adjust_tbl, all_ones, + all_twos, all_e0s, inputs[2], first_len); + prev_first_len = first_len; + first_len = vqtbl1q_u8(first_len_tbl, vshrq_n_u8(inputs[3], 4)); + check_block_neon(inputs[2], prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, range_adjust_tbl, all_ones, + all_twos, all_e0s, inputs[3], first_len); + prev_first_len = first_len; + } + // Set prev_input based on last block. + prev_input = inputs[3]; + // Advance. + ptr += 64; + } + // Combine error carriers with a manually-unrolled loop, then check if + // anything went awry. + if (vmaxvq_u8(vorrq_u8(errors[0], errors[1])) != 0) { + return 0; + } + //'Roll back' our pointer a little to prepare for a slow search of the rest. + uint32_t token; + vst1q_lane_u32(&token, vreinterpretq_u32_u8(prev_input), 3); + uint8_t const *token_ptr = (uint8_t const *)&token; + ptrdiff_t rollback = 0; + // We must not roll back if no big blocks were processed, as then + // the fallback function would examine out-of-bounds data (#620). + // In that case, prev_input contains only nulls and we skip the if body. + if (token_ptr[3] >= 0x80u) { + // Look for an incomplete multi-byte code point + if (token_ptr[3] >= 0xC0u) { + rollback = 1; + } else if (token_ptr[2] >= 0xE0u) { + rollback = 2; + } else if (token_ptr[1] >= 0xF0u) { + rollback = 3; + } + } + // Finish the job. + uint8_t const *const small_ptr = ptr - rollback; + size_t const small_len = remaining + rollback; + return is_valid_utf8_fallback(small_ptr, small_len); +} + +#pragma GCC pop_options diff --git a/cbits/aligned-static-hs-data.c b/cbits/aligned-static-hs-data.c new file mode 100644 --- /dev/null +++ b/cbits/aligned-static-hs-data.c @@ -0,0 +1,756 @@ +// This file contains various chunks of raw static data that we can't +// put into GHC-Haskell primitive string literals because we perform +// /aligned/ reads with them. + +#include "MachDeps.h" +#include + +extern const char hs_bytestring_lower_hex_table[513]; +const char hs_bytestring_lower_hex_table[513] + __attribute__(( aligned(ALIGNMENT_WORD16) )) + = "000102030405060708090a0b0c0d0e0f" + "101112131415161718191a1b1c1d1e1f" + "202122232425262728292a2b2c2d2e2f" + "303132333435363738393a3b3c3d3e3f" + "404142434445464748494a4b4c4d4e4f" + "505152535455565758595a5b5c5d5e5f" + "606162636465666768696a6b6c6d6e6f" + "707172737475767778797a7b7c7d7e7f" + "808182838485868788898a8b8c8d8e8f" + "909192939495969798999a9b9c9d9e9f" + "a0a1a2a3a4a5a6a7a8a9aaabacadaeaf" + "b0b1b2b3b4b5b6b7b8b9babbbcbdbebf" + "c0c1c2c3c4c5c6c7c8c9cacbcccdcecf" + "d0d1d2d3d4d5d6d7d8d9dadbdcdddedf" + "e0e1e2e3e4e5e6e7e8e9eaebecedeeef" + "f0f1f2f3f4f5f6f7f8f9fafbfcfdfeff"; + +extern const char hs_bytestring_digit_pairs_table[201]; +const char hs_bytestring_digit_pairs_table[201] + __attribute__(( aligned(ALIGNMENT_WORD16) )) + = "00010203040506070809" + "10111213141516171819" + "20212223242526272829" + "30313233343536373839" + "40414243444546474849" + "50515253545556575859" + "60616263646566676869" + "70717273747576777879" + "80818283848586878889" + "90919293949596979899"; + +extern const uint64_t hs_bytestring_float_pow5_inv_split[31]; +const uint64_t hs_bytestring_float_pow5_inv_split[31] = { +// map (finv float_pow5_inv_bitcount) [0..float_max_inv_split] + 0x800000000000001, + 0x666666666666667, + 0x51eb851eb851eb9, + 0x4189374bc6a7efa, + 0x68db8bac710cb2a, + 0x53e2d6238da3c22, + 0x431bde82d7b634e, + 0x6b5fca6af2bd216, + 0x55e63b88c230e78, + 0x44b82fa09b5a52d, + 0x6df37f675ef6eae, + 0x57f5ff85e592558, + 0x465e6604b7a8447, + 0x709709a125da071, + 0x5a126e1a84ae6c1, + 0x480ebe7b9d58567, + 0x734aca5f6226f0b, + 0x5c3bd5191b525a3, + 0x49c97747490eae9, + 0x760f253edb4ab0e, + 0x5e72843249088d8, + 0x4b8ed0283a6d3e0, + 0x78e480405d7b966, + 0x60b6cd004ac9452, + 0x4d5f0a66a23a9db, + 0x7bcb43d769f762b, + 0x63090312bb2c4ef, + 0x4f3a68dbc8f03f3, + 0x7ec3daf94180651, + 0x65697bfa9acd1da, + 0x51212ffbaf0a7e2 +}; + +extern const uint64_t hs_bytestring_float_pow5_split[47]; +const uint64_t hs_bytestring_float_pow5_split[47] = { +// map (fnorm float_pow5_bitcount) [0..float_max_split] + 0x1000000000000000, + 0x1400000000000000, + 0x1900000000000000, + 0x1f40000000000000, + 0x1388000000000000, + 0x186a000000000000, + 0x1e84800000000000, + 0x1312d00000000000, + 0x17d7840000000000, + 0x1dcd650000000000, + 0x12a05f2000000000, + 0x174876e800000000, + 0x1d1a94a200000000, + 0x12309ce540000000, + 0x16bcc41e90000000, + 0x1c6bf52634000000, + 0x11c37937e0800000, + 0x16345785d8a00000, + 0x1bc16d674ec80000, + 0x1158e460913d0000, + 0x15af1d78b58c4000, + 0x1b1ae4d6e2ef5000, + 0x10f0cf064dd59200, + 0x152d02c7e14af680, + 0x1a784379d99db420, + 0x108b2a2c28029094, + 0x14adf4b7320334b9, + 0x19d971e4fe8401e7, + 0x1027e72f1f128130, + 0x1431e0fae6d7217c, + 0x193e5939a08ce9db, + 0x1f8def8808b02452, + 0x13b8b5b5056e16b3, + 0x18a6e32246c99c60, + 0x1ed09bead87c0378, + 0x13426172c74d822b, + 0x1812f9cf7920e2b6, + 0x1e17b84357691b64, + 0x12ced32a16a1b11e, + 0x178287f49c4a1d66, + 0x1d6329f1c35ca4bf, + 0x125dfa371a19e6f7, + 0x16f578c4e0a060b5, + 0x1cb2d6f618c878e3, + 0x11efc659cf7d4b8d, + 0x166bb7f0435c9e71, + 0x1c06a5ec5433c60d +}; + +extern const uint64_t hs_bytestring_double_pow5_inv_split[584]; +const uint64_t hs_bytestring_double_pow5_inv_split[584] = { +// splitWord128s $ map (finv double_pow5_inv_bitcount) [0..double_max_inv_split] + 0x1,0x2000000000000000, + 0x999999999999999a,0x1999999999999999, + 0x47ae147ae147ae15,0x147ae147ae147ae1, + 0x6c8b4395810624de,0x10624dd2f1a9fbe7, + 0x7a786c226809d496,0x1a36e2eb1c432ca5, + 0x61f9f01b866e43ab,0x14f8b588e368f084, + 0xb4c7f34938583622,0x10c6f7a0b5ed8d36, + 0x87a6520ec08d236a,0x1ad7f29abcaf4857, + 0x9fb841a566d74f88,0x15798ee2308c39df, + 0xe62d01511f12a607,0x112e0be826d694b2, + 0xd6ae6881cb5109a4,0x1b7cdfd9d7bdbab7, + 0xdef1ed34a2a73aea,0x15fd7fe17964955f, + 0x7f27f0f6e885c8bb,0x119799812dea1119, + 0x650cb4be40d60df8,0x1c25c268497681c2, + 0xea70909833de7193,0x16849b86a12b9b01, + 0x21f3a6e0297ec143,0x1203af9ee756159b, + 0x6985d7cd0f313537,0x1cd2b297d889bc2b, + 0x2137dfd73f5a90f9,0x170ef54646d49689, + 0xe75fe645cc4873fa,0x12725dd1d243aba0, + 0xa5663d3c7a0d865d,0x1d83c94fb6d2ac34, + 0x511e976394d79eb1,0x179ca10c9242235d, + 0xda7edf82dd794bc1,0x12e3b40a0e9b4f7d, + 0x2a6498d1625bac68,0x1e392010175ee596, + 0xeeb6e0a781e2f053,0x182db34012b25144, + 0x58924d52ce4f26a9,0x1357c299a88ea76a, + 0x27507bb7b07ea441,0x1ef2d0f5da7dd8aa, + 0x52a6c95fc0655034,0x18c240c4aecb13bb, + 0xeebd44c99eaa690,0x13ce9a36f23c0fc9, + 0xb17953adc3110a80,0x1fb0f6be50601941, + 0xc12ddc8b02740867,0x195a5efea6b34767, + 0x3424b06f3529a052,0x14484bfeebc29f86, + 0x901d59f290ee19db,0x1039d66589687f9e, + 0x4cfbc31db4b0295f,0x19f623d5a8a73297, + 0x3d9635b15d59bab2,0x14c4e977ba1f5bac, + 0x97ab5e277de16228,0x109d8792fb4c4956, + 0xf2abc9d8c9689d0d,0x1a95a5b7f87a0ef0, + 0x5bbca17a3aba173e,0x154484932d2e725a, + 0xafca1ac82efb45cb,0x11039d428a8b8eae, + 0xb2dcf7a6b1920945,0x1b38fb9daa78e44a, + 0xf57d92ebc141a104,0x15c72fb1552d836e, + 0xc46475896767b403,0x116c262777579c58, + 0x6d6d88dbd8a5ecd2,0x1be03d0bf225c6f4, + 0x8abe071646eb23db,0x164cfda3281e38c3, + 0x6efe6c11d255b649,0x11d7314f534b609c, + 0xb197134fb6ef8a0e,0x1c8b821885456760, + 0x27ac0f72f8bfa1a5,0x16d601ad376ab91a, + 0xb95672c260994e1e,0x1244ce242c5560e1, + 0xf5571e03cdc21695,0x1d3ae36d13bbce35, + 0x2aac18030b01abab,0x17624f8a762fd82b, + 0xbbbce0026f348956,0x12b50c6ec4f31355, + 0x92c7ccd0b1eda889,0x1dee7a4ad4b81eef, + 0xdbd30a408e57ba07,0x17f1fb6f10934bf2, + 0x7ca8d50071dfc806,0x1327fc58da0f6ff5, + 0xfaa7bb33e9660cd6,0x1ea6608e29b24cbb, + 0x9552fc298784d711,0x18851a0b548ea3c9, + 0xaaa8c9bad2d0ac0e,0x139dae6f76d88307, + 0xdddadc5e1e1aace3,0x1f62b0b257c0d1a5, + 0x7e48b04b4b488a4f,0x191bc08eac9a4151, + 0xcb6d59d5d5d3a1d9,0x141633a556e1cdda, + 0x3c577b1177dc817b,0x1011c2eaabe7d7e2, + 0xc6f25e825960cf2a,0x19b604aaaca62636, + 0x6bf518684780a5bb,0x14919d5556eb51c5, + 0x232a79ed06008496,0x10747ddddf22a7d1, + 0xd1dd8fe1a3340756,0x1a53fc9631d10c81, + 0xa7e4731ae8f66c45,0x150ffd44f4a73d34, + 0x531d28e253f8569e,0x10d9976a5d52975d, + 0xeb61db03b98d5762,0x1af5bf109550f22e, + 0xbc4e48cfc7a445e8,0x159165a6ddda5b58, + 0x6371d3d96c836b20,0x11411e1f17e1e2ad, + 0x9f1c8628ad9f11cd,0x1b9b6364f3030448, + 0xe5b06b53be18db0b,0x1615e91d8f359d06, + 0xeaf3890fcb4715a2,0x11ab20e472914a6b, + 0x44b8db4c7871bc37,0x1c45016d841baa46, + 0x3c715d6c6c1635f,0x169d9abe03495505, + 0x3638de456bcde919,0x1217aefe69077737, + 0x56c163a2461641c1,0x1cf2b1970e725858, + 0xdf011c81d1ab67ce,0x17288e1271f51379, + 0x7f3416ce4155eca5,0x1286d80ec190dc61, + 0x6520247d3556476e,0x1da48ce468e7c702, + 0xea801d30f7783925,0x17b6d71d20b96c01, + 0xbb99b0f3f92cfa84,0x12f8ac174d612334, + 0x5f5c4e532847f739,0x1e5aacf215683854, + 0x7f7d0b75b9d32c2e,0x18488a5b44536043, + 0x9930d5f7c7dc2358,0x136d3b7c36a919cf, + 0x8eb4898c72f9d226,0x1f152bf9f10e8fb2, + 0x722a07a38f2e41b8,0x18ddbcc7f40ba628, + 0xc1bb394fa5be9afa,0x13e497065cd61e86, + 0x9c5ec2190930f7f6,0x1fd424d6faf030d7, + 0x49e56814075a5ff8,0x197683df2f268d79, + 0x6e51201005e1e660,0x145ecfe5bf520ac7, + 0xf1da800cd181851a,0x104bd984990e6f05, + 0x4fc400148268d4f5,0x1a12f5a0f4e3e4d6, + 0xd96999aa01ed772b,0x14dbf7b3f71cb711, + 0xadee1488018ac5bc,0x10aff95cc5b09274, + 0x497ceda668de092c,0x1ab328946f80ea54, + 0x3aca57b853e4d424,0x155c2076bf9a5510, + 0x623b7960431d7683,0x1116805effaeaa73, + 0x9d2bf566d1c8bd9e,0x1b5733cb32b110b8, + 0x7dbcc452416d647f,0x15df5ca28ef40d60, + 0xcafd69db678ab6cc,0x117f7d4ed8c33de6, + 0xab2f0fc572778adf,0x1bff2ee48e052fd7, + 0x88f273045b92d580,0x1665bf1d3e6a8cac, + 0xd3f528d049424466,0x11eaff4a98553d56, + 0xb988414d4203a0a3,0x1cab3210f3bb9557, + 0x6139cdd76802e6e9,0x16ef5b40c2fc7779, + 0xe761717920025254,0x125915cd68c9f92d, + 0xa568b58e999d5086,0x1d5b561574765b7c, + 0x5120913ee14aa6d2,0x177c44ddf6c515fd, + 0xa74d40ff1aa21f0e,0x12c9d0b1923744ca, + 0xbaece64f769cb4a,0x1e0fb44f50586e11, + 0x3c8bd850c5ee3c3b,0x180c903f7379f1a7, + 0xca0979da37f1c9c9,0x133d4032c2c7f485, + 0xa9a8c2f6bfe942db,0x1ec866b79e0cba6f, + 0x2153cf2bccba9be3,0x18a0522c7e709526, + 0x1aa9728970954982,0x13b374f06526ddb8, + 0xf775840f1a88759d,0x1f8587e7083e2f8c, + 0x5f9136727ba05e17,0x19379fec0698260a, + 0x1940f85b9619e4df,0x142c7ff0054684d5, + 0xe100c6afab47ea4c,0x1023998cd1053710, + 0xce67a44c453fdd47,0x19d28f47b4d524e7, + 0xd852e9d69dccb106,0x14a8729fc3ddb71f, + 0x79dbee454b0a2738,0x1086c219697e2c19, + 0x295fe3a211a9d859,0x1a71368f0f30468f, + 0xbab31c81a7bb137a,0x15275ed8d8f36ba5, + 0x6228e39aec95a92f,0x10ec4be0ad8f8951, + 0x9d0e38f7e0ef7517,0x1b13ac9aaf4c0ee8, + 0xb0d82d931a592a79,0x15a956e225d67253, + 0x8d79be0f4847552e,0x11544581b7dec1dc, + 0x158f967eda0bbb7c,0x1bba08cf8c979c94, + 0x77a611ff14d62f97,0x162e6d72d6dfb076, + 0xf951a7ff43de8c79,0x11bebdf578b2f391, + 0xc21c3ffed2fdad8e,0x1c6463225ab7ec1c, + 0x1b0333242648ad8,0x16b6b5b5155ff017, + 0x159c28e9b83a246,0x122bc490dde659ac, + 0xcef604175f3903a3,0x1d12d41afca3c2ac, + 0x725e69ac4c2d9c83,0x17424348ca1c9bbd, + 0xf5185489d68ae39c,0x129b69070816e2fd, + 0xee8d540fbdab05c6,0x1dc574d80cf16b2f, + 0xbed77672fe226b05,0x17d12a4670c1228c, + 0xff12c528cb4ebc04,0x130dbb6b8d674ed6, + 0xcb513b74787df9a0,0x1e7c5f127bd87e24, + 0x90dc929f9fe614d,0x18637f41fcad31b7, + 0xa0d7d42194cb810a,0x1382cc34ca2427c5, + 0x67bfb9cf5478ce77,0x1f37ad21436d0c6f, + 0x1fcc94a5dd2d71f9,0x18f9574dcf8a7059, + 0x7fd6dd517dbdf4c7,0x13faac3e3fa1f37a, + 0xffbe2ee8c92fee0b,0x1ff779fd329cb8c3, + 0x6631bf20a0f324d6,0x1992c7fdc216fa36, + 0xb827cc1a1a5c1d78,0x14756ccb01abfb5e, + 0x935309ae7b7ce460,0x105df0a267bcc918, + 0x1eeb42b0c594a099,0x1a2fe76a3f9474f4, + 0xe58902270476e6e1,0x14f31f8832dd2a5c, + 0xb7a0ce859d2bebe7,0x10c27fa028b0eeb0, + 0x59014a6f61dfdfd8,0x1ad0cc33744e4ab4, + 0xe0cdd525e7e64cad,0x1573d68f903ea229, + 0x4d7177518651d6f1,0x11297872d9cbb4ee, + 0x7be8bee8d6e957e8,0x1b758d848fac54b0, + 0xfcba3253df211320,0x15f7a46a0c89dd59, + 0x63c8284318e74280,0x1192e9ee706e4aae, + 0x60d0d3827d86a66,0x1c1e43171a4a1117, + 0x6b3da42cecad21eb,0x167e9c127b6e7412, + 0x88fe1cf0bd574e56,0x11fee341fc585cdb, + 0x419694b462254a23,0x1ccb0536608d615f, + 0x67abaa29e81dd4e9,0x1708d0f84d3de77f, + 0xb95621bb2017dd87,0x126d73f9d764b932, + 0xc223692b668c95a5,0x1d7becc2f23ac1ea, + 0xce82ba891ed6de1d,0x179657025b6234bb, + 0xa53562074bdf1818,0x12deac01e2b4f6fc, + 0x3b889cd87964f359,0x1e3113363787f194, + 0xfc6d4a46c783f5e1,0x18274291c6065adc, + 0x30576e9f06032b1a,0x13529ba7d19eaf17, + 0x1a257dcb3cd1de90,0x1eea92a61c311825, + 0x481dfe3c30a7e540,0x18bba884e35a79b7, + 0xd34b31c9c0865100,0x13c9539d82aec7c5, + 0x5211e942cda3b4cd,0x1fa885c8d117a609, + 0x74db21023e1c90a4,0x19539e3a40dfb807, + 0xf715b401cb4a0d50,0x1442e4fb67196005, + 0xf8de299b09080aa7,0x103583fc527ab337, + 0x8e304291a80cddd7,0x19ef3993b72ab859, + 0x3e8d020e200a4b13,0x14bf6142f8eef9e1, + 0x653d9b3e80083c0f,0x10991a9bfa58c7e7, + 0x6ec8f864000d2ce4,0x1a8e90f9908e0ca5, + 0x8bd3f9e999a423ea,0x153eda614071a3b7, + 0x3ca994bae1501cbb,0x10ff151a99f482f9, + 0xc775bac49bb3612b,0x1b31bb5dc320d18e, + 0xd2c4956a16291a89,0x15c162b168e70e0b, + 0xdbd0778811ba7ba1,0x11678227871f3e6f, + 0x2c80bf401c5d929b,0x1bd8d03f3e9863e6, + 0xbd33cc3349e47549,0x16470cff6546b651, + 0xca8fd68f6e505dd4,0x11d270cc51055ea7, + 0x4419574be3b3c953,0x1c83e7ad4e6efdd9, + 0x347790982f63aa9,0x16cfec8aa52597e1, + 0xcf6c60d468c4fbba,0x123ff06eea847980, + 0xe57a34870e07f92a,0x1d331a4b10d3f59a, + 0x512e906c0b399422,0x175c1508da432ae2, + 0xda8ba6bcd5c7a9b5,0x12b010d3e1cf5581, + 0x90df712e22d90f87,0x1de6815302e5559c, + 0xda4c5a8b4f140c6c,0x17eb9aa8cf1dde16, + 0xaea37ba2a5a9a38a,0x1322e220a5b17e78, + 0x7dd25f6aa2a905a9,0x1e9e369aa2b59727, + 0x97db7f888220d154,0x187e92154ef7ac1f, + 0x797c6606ce80a777,0x139874ddd8c6234c, + 0x8f2d700ae4010bf1,0x1f5a549627a36bad, + 0xc2459a25000d65a,0x191510781fb5efbe, + 0x701d1481d99a4515,0x1410d9f9b2f7f2fe, + 0xc017439b147b6a77,0x100d7b2e28c65bfe, + 0xccf205c4ed9243f2,0x19af2b7d0e0a2cca, + 0xa5b37d0be0e9cc2,0x148c22ca71a1bd6f, + 0x848f973cb3ee3ce,0x10701bd527b4978c, + 0xda0e5bec78649fb0,0x1a4cf9550c5425ac, + 0x7b3eaff060507fc0,0x150a6110d6a9b7bd, + 0x95cbbff380406633,0x10d51a73deee2c97, + 0xefac665266cd7052,0x1aee90b964b04758, + 0x2623850eb8a459db,0x158ba6fab6f36c47, + 0x1e82d0d893b6ae49,0x113c85955f29236c, + 0xfd9e1af41f8ab075,0x1b9408eefea838ac, + 0x97b1af29b2d559f7,0x16100725988693bd, + 0xac8e25baf5777b2c,0x11a66c1e139edc97, + 0x7a7d092b2258c513,0x1c3d79c9b8fe2dbf, + 0x61fda0ef4ead6a76,0x169794a160cb57cc, + 0xe7fe1a590bbdeec5,0x1212dd4de7091309, + 0xa6635d5b45fcb13a,0x1ceafbafd80e84dc, + 0x851c4aaf6b308dc8,0x172262f3133ed0b0, + 0xd0e36ef2bc26d7d4,0x1281e8c275cbda26, + 0xb49f17eac6a48c86,0x1d9ca79d894629d7, + 0x2a18dfef0550706b,0x17b08617a104ee46, + 0x54e0b3259dd9f389,0x12f39e794d9d8b6b, + 0x87cdeb6f62f65274,0x1e5297287c2f4578, + 0xd30b22bf825ea85d,0x18421286c9bf6ac6, + 0xf3c1bcc684bb9e4,0x13680ed23aff889f, + 0x18602c7a4079296d,0x1f0ce4839198da98, + 0x46b356c833942124,0x18d71d360e13e213, + 0x388f78a029434db6,0x13df4a91a4dcb4dc, + 0x5a7f2766a86baf8a,0x1fcbaa82a1612160, + 0x153285ebb9efbfa2,0x196fbb9bb44db44d, + 0xaa8ed189618c994e,0x145962e2f6a4903d, + 0xeed8a7a11ad6e10c,0x1047824f2bb6d9ca, + 0x7e27729b5e249b45,0x1a0c03b1df8af611, + 0xfe85f549181d4904,0x14d6695b193bf80d, + 0xcb9e5dd4134aa0d0,0x10ab877c142ff9a4, + 0xdf63c9535211014d,0x1aac0bf9b9e65c3a, + 0x191ca10f74da6771,0x15566ffafb1eb02f, + 0xadb080d92a4852c1,0x1111f32f2f4bc025, + 0x15e7348eaa0d5134,0x1b4feb7eb212cd09, + 0xab1f5d3eee710dc4,0x15d98932280f0a6d, + 0xbc1917658b8da49d,0x117ad428200c0857, + 0x2cf4f23c127c3a94,0x1bf7b9d9cce00d59, + 0xf0c3f4fcdb969543,0x165fc7e170b33de0, + 0x5a365d9716121103,0x11e6398126f5cb1a, + 0x9056fc24f01ce804,0x1ca38f350b22de90, + 0xd9df301d8ce3ecd0,0x16e93f5da2824ba6, + 0xe17f59b13d8323da,0x125432b14ecea2eb, + 0x68cbc2b52f38395c,0x1d53844ee47dd179, + 0x53d6355dbf602de3,0x177603725064a794, + 0xa9782ab165e68b1c,0x12c4cf8ea6b6ec76, + 0xf26aab56fd744fa,0x1e07b27dd78b13f1, + 0x3f52222abfdf6a62,0x18062864ac6f4327, + 0x65db4e88997f884e,0x1338205089f29c1f, + 0x6fc54a7428cc0d4a,0x1ec033b40fea9365, + 0x596aa1f68709a43b,0x1899c2f673220f84, + 0xadeee7f86c07b696,0x13ae3591f5b4d936, + 0x497e3ff3e00c5756,0x1f7d228322baf524, + 0xd464fff64cd6ac45,0x1930e868e89590e9, + 0x4383fff83d7889d1,0x14272053ed4473ee, + 0xcf9cccc69793a174,0x101f4d0ff1038ff1, + 0x7f6147a425b90252,0x19cbae7fe805b31c, + 0xcc4dd2e9b7c7350f,0x14a2f1ffecd15c16, + 0x3d0b0f215fd290d9,0x10825b3323dab012, + 0x61ab4b689950e7c1,0x1a6a2b85062ab350, + 0x4e22a2ba1440b967,0x1521bc6a6b555c40, + 0xb4ee894dd009453,0x10e7c9eebc4449cd, + 0x1217da87c800ed51,0x1b0c764ac6d3a948, + 0xdb46486ca000bdda,0x15a391d56bdc876c, + 0x490506bd4ccd64af,0x114fa7ddefe39f8a, + 0xa8080ac87ae23ab1,0x1bb2a62fe638ff43, + 0x5339a239fbe82ef4,0x162884f31e93ff69, + 0x75c7b4fb2fecf25d,0x11ba03f5b20fff87, + 0x22d92191e647ea2e,0x1c5cd322b67fff3f, + 0xb57a8141850654f2,0x16b0a8e891ffff65, + 0xc4620101373843f5,0x1226ed86db3332b7, + 0x3a366801f1f39fee,0x1d0b15a491eb8459, + 0xfb5eb99b27f6198b,0x173c115074bc69e0, + 0x2f7efae2865e7ad6,0x129674405d6387e7, + 0xe597f7d0d6fd9156,0x1dbd86cd6238d971, + 0x8479930d78cadaab,0x17cad23de82d7ac1, + 0xd06142712d6f1556,0x1308a831868ac89a, + 0x4d686a4eaf182222,0x1e74404f3daada91, + 0xa453883ef279b4e8,0x185d003f6488aeda, + 0xe9dc6cff28615d87,0x137d99cc506d58ae, + 0xa960ae650d6895a4,0x1f2f5c7a1a488de4, + 0xbab3beb73ded4483,0x18f2b061aea07183, + 0x2ef6322c318a9d36,0x13f559e7bee6c136 +}; + +extern const uint64_t hs_bytestring_double_pow5_split[652]; +const uint64_t hs_bytestring_double_pow5_split[652] = { +// splitWord128s $ map (fnorm double_pow5_bitcount) [0..double_max_split] + 0x0,0x1000000000000000, + 0x0,0x1400000000000000, + 0x0,0x1900000000000000, + 0x0,0x1f40000000000000, + 0x0,0x1388000000000000, + 0x0,0x186a000000000000, + 0x0,0x1e84800000000000, + 0x0,0x1312d00000000000, + 0x0,0x17d7840000000000, + 0x0,0x1dcd650000000000, + 0x0,0x12a05f2000000000, + 0x0,0x174876e800000000, + 0x0,0x1d1a94a200000000, + 0x0,0x12309ce540000000, + 0x0,0x16bcc41e90000000, + 0x0,0x1c6bf52634000000, + 0x0,0x11c37937e0800000, + 0x0,0x16345785d8a00000, + 0x0,0x1bc16d674ec80000, + 0x0,0x1158e460913d0000, + 0x0,0x15af1d78b58c4000, + 0x0,0x1b1ae4d6e2ef5000, + 0x0,0x10f0cf064dd59200, + 0x0,0x152d02c7e14af680, + 0x0,0x1a784379d99db420, + 0x0,0x108b2a2c28029094, + 0x0,0x14adf4b7320334b9, + 0x4000000000000000,0x19d971e4fe8401e7, + 0x8800000000000000,0x1027e72f1f128130, + 0xaa00000000000000,0x1431e0fae6d7217c, + 0xd480000000000000,0x193e5939a08ce9db, + 0xc9a0000000000000,0x1f8def8808b02452, + 0xbe04000000000000,0x13b8b5b5056e16b3, + 0xad85000000000000,0x18a6e32246c99c60, + 0xd8e6400000000000,0x1ed09bead87c0378, + 0x878fe80000000000,0x13426172c74d822b, + 0x6973e20000000000,0x1812f9cf7920e2b6, + 0x3d0da8000000000,0x1e17b84357691b64, + 0x8262889000000000,0x12ced32a16a1b11e, + 0x22fb2ab400000000,0x178287f49c4a1d66, + 0xabb9f56100000000,0x1d6329f1c35ca4bf, + 0xcb54395ca0000000,0x125dfa371a19e6f7, + 0xbe2947b3c8000000,0x16f578c4e0a060b5, + 0x2db399a0ba000000,0x1cb2d6f618c878e3, + 0xfc90400474400000,0x11efc659cf7d4b8d, + 0x7bb4500591500000,0x166bb7f0435c9e71, + 0xdaa16406f5a40000,0x1c06a5ec5433c60d, + 0xa8a4de8459868000,0x118427b3b4a05bc8, + 0xd2ce16256fe82000,0x15e531a0a1c872ba, + 0x87819baecbe22800,0x1b5e7e08ca3a8f69, + 0xf4b1014d3f6d5900,0x111b0ec57e6499a1, + 0x71dd41a08f48af40,0x1561d276ddfdc00a, + 0xe549208b31adb10,0x1aba4714957d300d, + 0x28f4db456ff0c8ea,0x10b46c6cdd6e3e08, + 0x33321216cbecfb24,0x14e1878814c9cd8a, + 0xbffe969c7ee839ed,0x1a19e96a19fc40ec, + 0xf7ff1e21cf512434,0x105031e2503da893, + 0xf5fee5aa43256d41,0x14643e5ae44d12b8, + 0x337e9f14d3eec892,0x197d4df19d605767, + 0x5e46da08ea7ab6,0x1fdca16e04b86d41, + 0xa03aec4845928cb2,0x13e9e4e4c2f34448, + 0xc849a75a56f72fde,0x18e45e1df3b0155a, + 0x7a5c1130ecb4fbd6,0x1f1d75a5709c1ab1, + 0xec798abe93f11d65,0x13726987666190ae, + 0xa797ed6e38ed64bf,0x184f03e93ff9f4da, + 0x517de8c9c728bdef,0x1e62c4e38ff87211, + 0xd2eeb17e1c7976b5,0x12fdbb0e39fb474a, + 0x87aa5ddda397d462,0x17bd29d1c87a191d, + 0xe994f5550c7dc97b,0x1dac74463a989f64, + 0x11fd195527ce9ded,0x128bc8abe49f639f, + 0xd67c5faa71c24568,0x172ebad6ddc73c86, + 0x8c1b77950e32d6c2,0x1cfa698c95390ba8, + 0x57912abd28dfc639,0x121c81f7dd43a749, + 0xad75756c7317b7c8,0x16a3a275d494911b, + 0x98d2d2c78fdda5ba,0x1c4c8b1349b9b562, + 0x9f83c3bcb9ea8794,0x11afd6ec0e14115d, + 0x764b4abe8652979,0x161bcca7119915b5, + 0x493de1d6e27e73d7,0x1ba2bfd0d5ff5b22, + 0x6dc6ad264d8f0866,0x1145b7e285bf98f5, + 0xc938586fe0f2ca80,0x159725db272f7f32, + 0x7b866e8bd92f7d20,0x1afcef51f0fb5eff, + 0xad34051767bdae34,0x10de1593369d1b5f, + 0x9881065d41ad19c1,0x15159af804446237, + 0x7ea147f492186032,0x1a5b01b605557ac5, + 0x6f24ccf8db4f3c1f,0x1078e111c3556cbb, + 0x4aee003712230b27,0x14971956342ac7ea, + 0xdda98044d6abcdf0,0x19bcdfabc13579e4, + 0xa89f02b062b60b6,0x10160bcb58c16c2f, + 0xcd2c6c35c7b638e4,0x141b8ebe2ef1c73a, + 0x8077874339a3c71d,0x1922726dbaae3909, + 0xe0956914080cb8e4,0x1f6b0f092959c74b, + 0x6c5d61ac8507f38e,0x13a2e965b9d81c8f, + 0x4774ba17a649f072,0x188ba3bf284e23b3, + 0x1951e89d8fdc6c8f,0x1eae8caef261aca0, + 0xfd3316279e9c3d9,0x132d17ed577d0be4, + 0x13c7fdbb186434cf,0x17f85de8ad5c4edd, + 0x58b9fd29de7d4203,0x1df67562d8b36294, + 0xb7743e3a2b0e4942,0x12ba095dc7701d9c, + 0xe5514dc8b5d1db92,0x17688bb5394c2503, + 0xdea5a13ae3465277,0x1d42aea2879f2e44, + 0xb2784c4ce0bf38a,0x1249ad2594c37ceb, + 0xcdf165f6018ef06d,0x16dc186ef9f45c25, + 0x416dbf7381f2ac88,0x1c931e8ab871732f, + 0x88e497a83137abd5,0x11dbf316b346e7fd, + 0xeb1dbd923d8596ca,0x1652efdc6018a1fc, + 0x25e52cf6cce6fc7d,0x1be7abd3781eca7c, + 0x97af3c1a40105dce,0x1170cb642b133e8d, + 0xfd9b0b20d0147542,0x15ccfe3d35d80e30, + 0x3d01cde904199292,0x1b403dcc834e11bd, + 0x462120b1a28ffb9b,0x1108269fd210cb16, + 0xd7a968de0b33fa82,0x154a3047c694fddb, + 0xcd93c3158e00f923,0x1a9cbc59b83a3d52, + 0xc07c59ed78c09bb6,0x10a1f5b813246653, + 0xb09b7068d6f0c2a3,0x14ca732617ed7fe8, + 0xdcc24c830cacf34c,0x19fd0fef9de8dfe2, + 0xc9f96fd1e7ec180f,0x103e29f5c2b18bed, + 0x3c77cbc661e71e13,0x144db473335deee9, + 0x8b95beb7fa60e598,0x1961219000356aa3, + 0x6e7b2e65f8f91efe,0x1fb969f40042c54c, + 0xc50cfcffbb9bb35f,0x13d3e2388029bb4f, + 0xb6503c3faa82a037,0x18c8dac6a0342a23, + 0xa3e44b4f95234844,0x1efb1178484134ac, + 0xe66eaf11bd360d2b,0x135ceaeb2d28c0eb, + 0xe00a5ad62c839075,0x183425a5f872f126, + 0x980cf18bb7a47493,0x1e412f0f768fad70, + 0x5f0816f752c6c8dc,0x12e8bd69aa19cc66, + 0xf6ca1cb527787b13,0x17a2ecc414a03f7f, + 0xf47ca3e2715699d7,0x1d8ba7f519c84f5f, + 0xf8cde66d86d62026,0x127748f9301d319b, + 0xf7016008e88ba830,0x17151b377c247e02, + 0xb4c1b80b22ae923c,0x1cda62055b2d9d83, + 0x50f91306f5ad1b65,0x12087d4358fc8272, + 0xe53757c8b318623f,0x168a9c942f3ba30e, + 0x9e852dbadfde7acf,0x1c2d43b93b0a8bd2, + 0xa3133c94cbeb0cc1,0x119c4a53c4e69763, + 0x8bd80bb9fee5cff1,0x16035ce8b6203d3c, + 0xaece0ea87e9f43ee,0x1b843422e3a84c8b, + 0x4d40c9294f238a75,0x1132a095ce492fd7, + 0x2090fb73a2ec6d12,0x157f48bb41db7bcd, + 0x68b53a508ba78856,0x1adf1aea12525ac0, + 0x417144725748b536,0x10cb70d24b7378b8, + 0x51cd958eed1ae283,0x14fe4d06de5056e6, + 0xe640faf2a8619b24,0x1a3de04895e46c9f, + 0xefe89cd7a93d00f7,0x1066ac2d5daec3e3, + 0xebe2c40d938c4134,0x14805738b51a74dc, + 0x26db7510f86f5181,0x19a06d06e2611214, + 0x9849292a9b4592f1,0x100444244d7cab4c, + 0xbe5b73754216f7ad,0x1405552d60dbd61f, + 0xadf25052929cb598,0x1906aa78b912cba7, + 0x996ee4673743e2ff,0x1f485516e7577e91, + 0xffe54ec0828a6ddf,0x138d352e5096af1a, + 0xbfdea270a32d0957,0x18708279e4bc5ae1, + 0x2fd64b0ccbf84bad,0x1e8ca3185deb719a, + 0x5de5eee7ff7b2f4c,0x1317e5ef3ab32700, + 0x755f6aa1ff59fb1f,0x17dddf6b095ff0c0, + 0x92b7454a7f3079e7,0x1dd55745cbb7ecf0, + 0x5bb28b4e8f7e4c30,0x12a5568b9f52f416, + 0xf29f2e22335ddf3c,0x174eac2e8727b11b, + 0xef46f9aac035570b,0x1d22573a28f19d62, + 0xd58c5c0ab8215667,0x123576845997025d, + 0x4aef730d6629ac01,0x16c2d4256ffcc2f5, + 0x9dab4fd0bfb41701,0x1c73892ecbfbf3b2, + 0xa28b11e277d08e60,0x11c835bd3f7d784f, + 0x8b2dd65b15c4b1f9,0x163a432c8f5cd663, + 0x6df94bf1db35de77,0x1bc8d3f7b3340bfc, + 0xc4bbcf772901ab0a,0x115d847ad000877d, + 0x35eac354f34215cd,0x15b4e5998400a95d, + 0x8365742a30129b40,0x1b221effe500d3b4, + 0xd21f689a5e0ba108,0x10f5535fef208450, + 0x6a742c0f58e894a,0x1532a837eae8a565, + 0x4851137132f22b9d,0x1a7f5245e5a2cebe, + 0xed32ac26bfd75b42,0x108f936baf85c136, + 0xa87f57306fcd3212,0x14b378469b673184, + 0xd29f2cfc8bc07e97,0x19e056584240fde5, + 0xa3a37c1dd7584f1e,0x102c35f729689eaf, + 0x8c8c5b254d2e62e6,0x14374374f3c2c65b, + 0x6faf71eea079fb9f,0x1945145230b377f2, + 0xb9b4e6a48987a87,0x1f965966bce055ef, + 0x674111026d5f4c94,0x13bdf7e0360c35b5, + 0xc111554308b71fba,0x18ad75d8438f4322, + 0x7155aa93cae4e7a8,0x1ed8d34e547313eb, + 0x26d58a9c5ecf10c9,0x13478410f4c7ec73, + 0xf08aed437682d4fb,0x1819651531f9e78f, + 0xecada89454238a3a,0x1e1fbe5a7e786173, + 0x73ec895cb4963664,0x12d3d6f88f0b3ce8, + 0x90e7abb3e1bbc3fd,0x1788ccb6b2ce0c22, + 0x352196a0da2ab4fd,0x1d6affe45f818f2b, + 0x134fe24885ab11e,0x1262dfeebbb0f97b, + 0xc1823dadaa715d65,0x16fb97ea6a9d37d9, + 0x31e2cd19150db4bf,0x1cba7de5054485d0, + 0x1f2dc02fad2890f7,0x11f48eaf234ad3a2, + 0xa6f9303b9872b535,0x1671b25aec1d888a, + 0x50b77c4a7e8f6282,0x1c0e1ef1a724eaad, + 0x5272adae8f199d91,0x1188d357087712ac, + 0x670f591a32e004f6,0x15eb082cca94d757, + 0x40d32f60bf980633,0x1b65ca37fd3a0d2d, + 0x4883fd9c77bf03e0,0x111f9e62fe44483c, + 0x5aa4fd0395aec4d8,0x156785fbbdd55a4b, + 0x314e3c447b1a760e,0x1ac1677aad4ab0de, + 0xded0e5aaccf089c9,0x10b8e0acac4eae8a, + 0x96851f15802cac3b,0x14e718d7d7625a2d, + 0xfc2666dae037d74a,0x1a20df0dcd3af0b8, + 0x9d980048cc22e68e,0x10548b68a044d673, + 0x84fe005aff2ba032,0x1469ae42c8560c10, + 0xa63d8071bef6883e,0x198419d37a6b8f14, + 0xcfcce08e2eb42a4e,0x1fe52048590672d9, + 0x21e00c58dd309a70,0x13ef342d37a407c8, + 0x2a580f6f147cc10d,0x18eb0138858d09ba, + 0xb4ee134ad99bf150,0x1f25c186a6f04c28, + 0x7114cc0ec80176d2,0x137798f428562f99, + 0xcd59ff127a01d486,0x18557f31326bbb7f, + 0xc0b07ed7188249a8,0x1e6adefd7f06aa5f, + 0xd86e4f466f516e09,0x1302cb5e6f642a7b, + 0xce89e3180b25c98b,0x17c37e360b3d351a, + 0x822c5bde0def3bee,0x1db45dc38e0c8261, + 0xf15bb96ac8b58575,0x1290ba9a38c7d17c, + 0x2db2a7c57ae2e6d2,0x1734e940c6f9c5dc, + 0x391f51b6d99ba086,0x1d022390f8b83753, + 0x3b3931248014454,0x1221563a9b732294, + 0x4a077d6da019569,0x16a9abc9424feb39, + 0x45c895cc9081fac3,0x1c5416bb92e3e607, + 0x8b9d5d9fda513cba,0x11b48e353bce6fc4, + 0xae84b507d0e58be8,0x1621b1c28ac20bb5, + 0x1a25e249c51eeee3,0x1baa1e332d728ea3, + 0xf057ad6e1b33554d,0x114a52dffc679925, + 0x6c6d98c9a2002aa1,0x159ce797fb817f6f, + 0x4788fefc0a803549,0x1b04217dfa61df4b, + 0xcb59f5d8690214e,0x10e294eebc7d2b8f, + 0xcfe30734e83429a1,0x151b3a2a6b9c7672, + 0x83dbc9022241340a,0x1a6208b50683940f, + 0xb2695da15568c086,0x107d457124123c89, + 0x1f03b509aac2f0a7,0x149c96cd6d16cbac, + 0x26c4a24c1573acd1,0x19c3bc80c85c7e97, + 0x783ae56f8d684c03,0x101a55d07d39cf1e, + 0x16499ecb70c25f03,0x1420eb449c8842e6, + 0x9bdc067e4cf2f6c4,0x19292615c3aa539f, + 0x82d3081de02fb476,0x1f736f9b3494e887, + 0xb1c3e512ac1dd0c9,0x13a825c100dd1154, + 0xde34de57572544fc,0x18922f31411455a9, + 0x55c215ed2cee963b,0x1eb6bafd91596b14, + 0xb5994db43c151de5,0x133234de7ad7e2ec, + 0xe2ffa1214b1a655e,0x17fec216198ddba7, + 0xdbbf89699de0feb6,0x1dfe729b9ff15291, + 0x2957b5e202ac9f31,0x12bf07a143f6d39b, + 0xf3ada35a8357c6fe,0x176ec98994f48881, + 0x70990c31242db8bd,0x1d4a7bebfa31aaa2, + 0x865fa79eb69c9376,0x124e8d737c5f0aa5, + 0xe7f791866443b854,0x16e230d05b76cd4e, + 0xa1f575e7fd54a669,0x1c9abd04725480a2, + 0xa53969b0fe54e801,0x11e0b622c774d065, + 0xe87c41d3dea2202,0x1658e3ab7952047f, + 0xd229b5248d64aa82,0x1bef1c9657a6859e, + 0x435a1136d85eea91,0x117571ddf6c81383, + 0x143095848e76a536,0x15d2ce55747a1864, + 0x193cbae5b2144e83,0x1b4781ead1989e7d, + 0x2fc5f4cf8f4cb112,0x110cb132c2ff630e, + 0xbbb77203731fdd56,0x154fdd7f73bf3bd1, + 0x2aa54e844fe7d4ac,0x1aa3d4df50af0ac6, + 0xdaa75112b1f0e4eb,0x10a6650b926d66bb, + 0xd15125575e6d1e26,0x14cffe4e7708c06a, + 0x85a56ead360865b0,0x1a03fde214caf085, + 0x7387652c41c53f8e,0x10427ead4cfed653, + 0x50693e7752368f71,0x14531e58a03e8be8, + 0x64838e1526c4334e,0x1967e5eec84e2ee2, + 0xfda4719a70754022,0x1fc1df6a7a61ba9a, + 0xde86c70086494815,0x13d92ba28c7d14a0, + 0x162878c0a7db9a1a,0x18cf768b2f9c59c9, + 0x5bb296f0d1d280a1,0x1f03542dfb83703b, + 0x194f9e5683239064,0x1362149cbd322625, + 0x5fa385ec23ec747e,0x183a99c3ec7eafae, + 0xf78c67672ce7919d,0x1e494034e79e5b99, + 0x3ab7c0a07c10bb02,0x12edc82110c2f940, + 0x4965b0c89b14e9c3,0x17a93a2954f3b790, + 0x5bbf1cfac1da2433,0x1d9388b3aa30a574, + 0xb957721cb92856a0,0x127c35704a5e6768, + 0xe7ad4ea3e7726c48,0x171b42cc5cf60142, + 0xa198a24ce14f075a,0x1ce2137f74338193, + 0x44ff65700cd16498,0x120d4c2fa8a030fc, + 0x563f3ecc1005bdbe,0x16909f3b92c83d3b, + 0x2bcf0e7f14072d2e,0x1c34c70a777a4c8a, + 0x5b61690f6c847c3d,0x11a0fc668aac6fd6, + 0xf239c35347a59b4c,0x16093b802d578bcb, + 0xeec83428198f021f,0x1b8b8a6038ad6ebe, + 0x553d20990ff96153,0x1137367c236c6537, + 0x2a8c68bf53f7b9a8,0x1585041b2c477e85, + 0x752f82ef28f5a812,0x1ae64521f7595e26, + 0x93db1d57999890b,0x10cfeb353a97dad8, + 0xb8d1e4ad7ffeb4e,0x1503e602893dd18e, + 0x8e7065dd8dffe622,0x1a44df832b8d45f1, + 0xf9063faa78bfefd5,0x106b0bb1fb384bb6, + 0xb747cf9516efebca,0x1485ce9e7a065ea4, + 0xe519c37a5cabe6bd,0x19a742461887f64d, + 0xaf301a2c79eb7036,0x1008896bcf54f9f0, + 0xdafc20b798664c43,0x140aabc6c32a386c, + 0x11bb28e57e7fdf54,0x190d56b873f4c688, + 0x1629f31ede1fd72a,0x1f50ac6690f1f82a, + 0x4dda37f34ad3e67a,0x13926bc01a973b1a, + 0xe150c5f01d88e019,0x187706b0213d09e0, + 0x19a4f76c24eb181f,0x1e94c85c298c4c59, + 0xb0071aa39712ef13,0x131cfd3999f7afb7, + 0x9c08e14c7cd7aad8,0x17e43c8800759ba5, + 0x30b199f9c0d958e,0x1ddd4baa0093028f, + 0x61e6f003c1887d79,0x12aa4f4a405be199, + 0xba60ac04b1ea9cd7,0x1754e31cd072d9ff, + 0xa8f8d705de65440d,0x1d2a1be4048f907f, + 0xc99b8663aaff4a88,0x123a516e82d9ba4f, + 0xbc0267fc95bf1d2a,0x16c8e5ca239028e3, + 0xab0301fbbb2ee474,0x1c7b1f3cac74331c, + 0xeae1e13d54fd4ec9,0x11ccf385ebc89ff1, + 0x659a598caa3ca27b,0x1640306766bac7ee, + 0xff00efefd4cbcb1a,0x1bd03c81406979e9, + 0x3f6095f5e4ff5ef0,0x116225d0c841ec32, + 0xcf38bb735e3f36ac,0x15baaf44fa52673e, + 0x8306ea5035cf0457,0x1b295b1638e7010e, + 0x11e4527221a162b6,0x10f9d8ede39060a9, + 0x565d670eaa09bb64,0x15384f295c7478d3, + 0x2bf4c0d2548c2a3d,0x1a8662f3b3919708, + 0x1b78f88374d79a66,0x1093fdd8503afe65, + 0x625736a4520d8100,0x14b8fd4e6449bdfe, + 0xfaed044d6690e140,0x19e73ca1fd5c2d7d, + 0xbcd422b0601a8cc8,0x103085e53e599c6e, + 0x6c092b5c78212ffa,0x143ca75e8df0038a, + 0x70b763396297bf8,0x194bd136316c046d, + 0x48ce53c07bb3daf6,0x1f9ec583bdc70588, + 0x2d80f4584d5068da,0x13c33b72569c6375, + 0x78e1316e60a48310,0x18b40a4eec437c52 +}; diff --git a/cbits/fpstring.c b/cbits/fpstring.c --- a/cbits/fpstring.c +++ b/cbits/fpstring.c @@ -29,10 +29,25 @@ * SUCH DAMAGE. */ +#include "HsFFI.h" +#include "MachDeps.h" + #include "fpstring.h" +#if defined(__x86_64__) +#include +#include +#endif +#include +#include + +#if defined(__x86_64__) && (__GNUC__ >= 7 || __GNUC__ == 6 && __GNUC_MINOR__ >= 3 || defined(__clang_major__)) && !defined(__STDC_NO_ATOMICS__) +#include +#define USE_SIMD_COUNT +#endif + /* copy a string in reverse */ -void fps_reverse(unsigned char *q, unsigned char *p, unsigned long n) { +void fps_reverse(unsigned char *q, unsigned char *p, size_t n) { p += n-1; while (n-- != 0) *q++ = *p--; @@ -42,9 +57,23 @@ of the duplicated string */ void fps_intersperse(unsigned char *q, unsigned char *p, - unsigned long n, + size_t n, unsigned char c) { - +#if defined(__x86_64__) + { + const __m128i separator = _mm_set1_epi8(c); + const unsigned char *const p_begin = p; + const unsigned char *const p_end = p_begin + n - 9; + while (p < p_end) { + const __m128i eight_src_bytes = _mm_loadl_epi64((__m128i *)p); + const __m128i sixteen_dst_bytes = _mm_unpacklo_epi8(eight_src_bytes, separator); + _mm_storeu_si128((__m128i *)q, sixteen_dst_bytes); + p += 8; + q += 16; + } + n -= p - p_begin; + } +#endif while (n > 1) { *q++ = *p++; *q++ = c; @@ -55,7 +84,7 @@ } /* find maximum char in a packed string */ -unsigned char fps_maximum(unsigned char *p, unsigned long len) { +unsigned char fps_maximum(unsigned char *p, size_t len) { unsigned char *q, c = *p; for (q = p; q < p + len; q++) if (*q > c) @@ -64,7 +93,7 @@ } /* find minimum char in a packed string */ -unsigned char fps_minimum(unsigned char *p, unsigned long len) { +unsigned char fps_minimum(unsigned char *p, size_t len) { unsigned char *q, c = *p; for (q = p; q < p + len; q++) if (*q < c) @@ -72,11 +101,218 @@ return c; } -/* count the number of occurences of a char in a string */ -unsigned long fps_count(unsigned char *p, unsigned long len, unsigned char w) { - unsigned long c; - for (c = 0; len-- != 0; ++p) - if (*p == w) +int fps_compare(const void *a, const void *b) { + return (int)*(unsigned char*)a - (int)*(unsigned char*)b; +} + +void fps_sort(unsigned char *p, size_t len) { + return qsort(p, len, 1, fps_compare); +} + +// We don't actually always use these unaligned write functions on the +// Haskell side, but the macros we check there aren't visible here... +void fps_unaligned_write_u16(uint16_t x, uint8_t *p) { + memcpy(p, &x, 2); + return; +} + +void fps_unaligned_write_u32(uint32_t x, uint8_t *p) { + memcpy(p, &x, 4); + return; +} + +void fps_unaligned_write_u64(uint64_t x, uint8_t *p) { + memcpy(p, &x, 8); + return; +} + +void fps_unaligned_write_HsFloat(HsFloat x, uint8_t *p) { + memcpy(p, &x, SIZEOF_HSFLOAT); +} + +void fps_unaligned_write_HsDouble(HsDouble x, uint8_t *p) { + memcpy(p, &x, SIZEOF_HSDOUBLE); +} + +uint64_t fps_unaligned_read_u64(uint8_t *p) { + uint64_t ans; + memcpy(&ans, p, 8); + return ans; +} + +/* count the number of occurrences of a char in a string */ +size_t fps_count_naive(unsigned char *str, size_t len, unsigned char w) { + size_t c; + for (c = 0; len-- != 0; ++str) + if (*str == w) ++c; return c; +} + + +#ifdef USE_SIMD_COUNT +__attribute__((target("sse4.2"))) +size_t fps_count_cmpestrm(unsigned char *str, size_t len, unsigned char w) { + const __m128i pat = _mm_set1_epi8(w); + + size_t res = 0; + + size_t i = 0; + + for (; i < len && (intptr_t)(str + i) % 64; ++i) { + res += str[i] == w; + } + + for (size_t end = len - 128; i < end; i += 128) { + __m128i p0 = _mm_load_si128((const __m128i*)(str + i + 16 * 0)); + __m128i p1 = _mm_load_si128((const __m128i*)(str + i + 16 * 1)); + __m128i p2 = _mm_load_si128((const __m128i*)(str + i + 16 * 2)); + __m128i p3 = _mm_load_si128((const __m128i*)(str + i + 16 * 3)); + __m128i p4 = _mm_load_si128((const __m128i*)(str + i + 16 * 4)); + __m128i p5 = _mm_load_si128((const __m128i*)(str + i + 16 * 5)); + __m128i p6 = _mm_load_si128((const __m128i*)(str + i + 16 * 6)); + __m128i p7 = _mm_load_si128((const __m128i*)(str + i + 16 * 7)); + // Here, cmpestrm compares two strings in the following mode: + // * _SIDD_SBYTE_OPS: interprets the strings as consisting of 8-bit chars, + // * _SIDD_CMP_EQUAL_EACH: computes the number of `i`s + // for which `p[i]`, a part of `str`, is equal to `pat[i]` + // (the latter being always equal to `w`). + // + // q.v. https://software.intel.com/sites/landingpage/IntrinsicsGuide/#text=_mm_cmpestrm&expand=835 +#define MODE _SIDD_SBYTE_OPS | _SIDD_CMP_EQUAL_EACH + __m128i r0 = _mm_cmpestrm(p0, 16, pat, 16, MODE); + __m128i r1 = _mm_cmpestrm(p1, 16, pat, 16, MODE); + __m128i r2 = _mm_cmpestrm(p2, 16, pat, 16, MODE); + __m128i r3 = _mm_cmpestrm(p3, 16, pat, 16, MODE); + __m128i r4 = _mm_cmpestrm(p4, 16, pat, 16, MODE); + __m128i r5 = _mm_cmpestrm(p5, 16, pat, 16, MODE); + __m128i r6 = _mm_cmpestrm(p6, 16, pat, 16, MODE); + __m128i r7 = _mm_cmpestrm(p7, 16, pat, 16, MODE); +#undef MODE + res += _popcnt64(_mm_extract_epi64(r0, 0)); + res += _popcnt64(_mm_extract_epi64(r1, 0)); + res += _popcnt64(_mm_extract_epi64(r2, 0)); + res += _popcnt64(_mm_extract_epi64(r3, 0)); + res += _popcnt64(_mm_extract_epi64(r4, 0)); + res += _popcnt64(_mm_extract_epi64(r5, 0)); + res += _popcnt64(_mm_extract_epi64(r6, 0)); + res += _popcnt64(_mm_extract_epi64(r7, 0)); + } + + for (; i < len; ++i) { + res += str[i] == w; + } + + return res; +} + +__attribute__((target("avx2"))) +size_t fps_count_avx2(unsigned char *str, size_t len, unsigned char w) { + __m256i pat = _mm256_set1_epi8(w); + + size_t prefix = 0, res = 0; + + size_t i = 0; + + for (; i < len && (intptr_t)(str + i) % 64; ++i) { + prefix += str[i] == w; + } + + for (size_t end = len - 128; i < end; i += 128) { + __m256i p0 = _mm256_load_si256((const __m256i*)(str + i + 32 * 0)); + __m256i p1 = _mm256_load_si256((const __m256i*)(str + i + 32 * 1)); + __m256i p2 = _mm256_load_si256((const __m256i*)(str + i + 32 * 2)); + __m256i p3 = _mm256_load_si256((const __m256i*)(str + i + 32 * 3)); + __m256i r0 = _mm256_cmpeq_epi8(p0, pat); + __m256i r1 = _mm256_cmpeq_epi8(p1, pat); + __m256i r2 = _mm256_cmpeq_epi8(p2, pat); + __m256i r3 = _mm256_cmpeq_epi8(p3, pat); + res += _popcnt64(_mm256_extract_epi64(r0, 0)); + res += _popcnt64(_mm256_extract_epi64(r0, 1)); + res += _popcnt64(_mm256_extract_epi64(r0, 2)); + res += _popcnt64(_mm256_extract_epi64(r0, 3)); + res += _popcnt64(_mm256_extract_epi64(r1, 0)); + res += _popcnt64(_mm256_extract_epi64(r1, 1)); + res += _popcnt64(_mm256_extract_epi64(r1, 2)); + res += _popcnt64(_mm256_extract_epi64(r1, 3)); + res += _popcnt64(_mm256_extract_epi64(r2, 0)); + res += _popcnt64(_mm256_extract_epi64(r2, 1)); + res += _popcnt64(_mm256_extract_epi64(r2, 2)); + res += _popcnt64(_mm256_extract_epi64(r2, 3)); + res += _popcnt64(_mm256_extract_epi64(r3, 0)); + res += _popcnt64(_mm256_extract_epi64(r3, 1)); + res += _popcnt64(_mm256_extract_epi64(r3, 2)); + res += _popcnt64(_mm256_extract_epi64(r3, 3)); + } + + // _mm256_cmpeq_epi8(p, pat) returns a SIMD vector + // with `i`th byte consisting of eight `1`s if `p[i] == pat[i]`, + // and of eight `0`s otherwise, + // hence each matching byte is counted 8 times by popcnt. + // Dividing by 8 corrects for that. + res /= 8; + + res += prefix; + + for (; i < len; ++i) { + res += str[i] == w; + } + + return res; +} + +typedef size_t (*fps_impl_t) (unsigned char*, size_t, unsigned char); + +fps_impl_t select_fps_simd_impl() { + uint32_t eax = 0, ebx = 0, ecx = 0, edx = 0; + + uint32_t ecx1 = 0; + if (__get_cpuid(1, &eax, &ebx, &ecx, &edx)) { + ecx1 = ecx; + } + + const bool has_xsave = ecx1 & (1 << 26); + const bool has_popcnt = ecx1 & (1 << 23); + + if (__get_cpuid_count(7, 0, &eax, &ebx, &ecx, &edx)) { + const bool has_avx2 = has_xsave && (ebx & (1 << 5)); + if (has_avx2 && has_popcnt) { + return &fps_count_avx2; + } + } + + const bool has_sse42 = ecx1 & (1 << 19); + if (has_sse42 && has_popcnt) { + return &fps_count_cmpestrm; + } + + return &fps_count_naive; +} +#endif + + + +size_t fps_count(unsigned char *str, size_t len, unsigned char w) { +#ifndef USE_SIMD_COUNT + return fps_count_naive(str, len, w); +#else + // 1024 is a rough guesstimate of the string length + // for which the extra performance of the main SIMD loop + // starts to compensate the extra work and extra branching outside the SIMD loop. + // The real optimal number depends on the specific μarch + // and isn't worth optimizing for in this context, + // since counting characters in shorter strings is unlikely to be a hot spot. + if (len <= 1024) { + return fps_count_naive(str, len, w); + } + + static _Atomic fps_impl_t s_impl = (fps_impl_t)NULL; + fps_impl_t impl = atomic_load_explicit(&s_impl, memory_order_relaxed); + if (!impl) { + impl = select_fps_simd_impl(); + atomic_store_explicit(&s_impl, impl, memory_order_relaxed); + } + + return (*impl)(str, len, w); +#endif } diff --git a/cbits/is-valid-utf8.c b/cbits/is-valid-utf8.c new file mode 100644 --- /dev/null +++ b/cbits/is-valid-utf8.c @@ -0,0 +1,782 @@ +/* +Copyright (c) Koz Ross 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. +*/ +#pragma GCC push_options +#pragma GCC optimize("-O2") +#include +#include +#include +#include + +#ifdef __x86_64__ +#include +#include +#include +#if (__GNUC__ >= 7 || __GNUC__ == 6 && __GNUC_MINOR__ >= 3 || \ + defined(__clang_major__)) && \ + !defined(__STDC_NO_ATOMICS__) +#include +#include +#else +// This is needed to support CentOS 7, which has a very old GCC. +#define CRUFTY_GCC +#endif +#endif + +#include +#include "ghcplatform.h" + +#ifdef WORDS_BIGENDIAN +#define to_little_endian(x) __builtin_bswap64(x) +#else +#define to_little_endian(x) (x) +#endif + +// 0x80 in every 'lane'. +static uint64_t const high_bits_mask = 0x8080808080808080ULL; + +static inline uint64_t read_uint64(const uint64_t *p) { + uint64_t r; + memcpy(&r, p, 8); + return r; +} + +// stand-in for __builtin_ctzll, used because __builtin_ctzll can +// cause runtime linker issues for GHC in some exotic situations (#601) +// +// See also these ghc issues: +// * https://gitlab.haskell.org/ghc/ghc/-/issues/21787 +// * https://gitlab.haskell.org/ghc/ghc/-/issues/22011 +static inline int hs_bytestring_ctz64(const uint64_t x) { + // These CPP conditions are taken from ghc-prim: + // https://gitlab.haskell.org/ghc/ghc/-/blob/73b5c7ce33929e1f7c9283ed7c2860aa40f6d0ec/libraries/ghc-prim/cbits/ctz.c#L31-57 + // credit to Herbert Valerio Riedel, Erik de Castro Lopo +#if defined(__GNUC__) && (defined(i386_HOST_ARCH) || defined(powerpc_HOST_ARCH)) + uint32_t xhi = (uint32_t)(x >> 32); + uint32_t xlo = (uint32_t) x; + return xlo ? __builtin_ctz(xlo) : 32 + __builtin_ctz(xhi); +#elif SIZEOF_UNSIGNED_LONG == 8 + return __builtin_ctzl(x); +#elif SIZEOF_UNSIGNED_LONG_LONG == 8 + return __builtin_ctzll(x); +#else +# error no suitable __builtin_ctz() found +#endif +} + +static inline int is_valid_utf8_fallback(uint8_t const *const src, + size_t const len) { + uint8_t const *ptr = (uint8_t const *)src; + // This is 'one past the end' to make loop termination and bounds checks + // easier. + uint8_t const *const end = ptr + len; + while (ptr < end) { + uint8_t const byte = *ptr; + // Check if the byte is ASCII. + if (byte <= 0x7F) { + ptr++; + // If we saw one ASCII byte, as long as it's not whitespace, it's quite + // likely we'll see more. + bool is_not_whitespace = byte > 32; + // If possible, do a block-check ahead. + if ((ptr + 32 < end) && is_not_whitespace) { + uint64_t const *big_ptr = (uint64_t const *)ptr; + // Non-ASCII bytes have a set MSB. Thus, if we AND with 0x80 in every + // 'lane', we will get 0 if everything is ASCII, and something else + // otherwise. + uint64_t results[4] = { + to_little_endian(read_uint64(big_ptr)) & high_bits_mask, + to_little_endian(read_uint64((big_ptr + 1))) & high_bits_mask, + to_little_endian(read_uint64((big_ptr + 2))) & high_bits_mask, + to_little_endian(read_uint64((big_ptr + 3))) & high_bits_mask}; + if (results[0] == 0) { + ptr += 8; + if (results[1] == 0) { + ptr += 8; + if (results[2] == 0) { + ptr += 8; + if (results[3] == 0) { + ptr += 8; + } else { + ptr += (hs_bytestring_ctz64(results[3]) / 8); + } + } else { + ptr += (hs_bytestring_ctz64(results[2]) / 8); + } + } else { + ptr += (hs_bytestring_ctz64(results[1]) / 8); + } + } else { + ptr += (hs_bytestring_ctz64(results[0]) / 8); + } + } + } + // Check for a valid 2-byte sequence. + // + // We use a signed comparison to avoid an extra comparison with 0x80, since + // _signed_ 0x80 is -128. + else if (ptr + 1 < end && byte >= 0xC2 && byte <= 0xDF && + ((int8_t) * (ptr + 1)) <= (int8_t)0xBF) { + ptr += 2; + } + // Check for a valid 3-byte sequence. + else if (ptr + 2 < end && byte >= 0xE0 && byte <= 0xEF) { + uint8_t const byte2 = *(ptr + 1); + bool byte2_valid = (int8_t)byte2 <= (int8_t)0xBF; + bool byte3_valid = ((int8_t) * (ptr + 2)) <= (int8_t)0xBF; + if (byte2_valid && byte3_valid && + // E0, A0..BF, 80..BF + ((byte == 0xE0 && byte2 >= 0xA0) || + // E1..EC, 80..BF, 80..BF + (byte >= 0xE1 && byte <= 0xEC) || + // ED, 80..9F, 80..BF + (byte == 0xED && byte2 <= 0x9F) || + // EE..EF, 80..BF, 80..BF + (byte >= 0xEE && byte <= 0xEF))) { + ptr += 3; + } else { + return 0; + } + } + // Check for a valid 4-byte sequence. + else if (ptr + 3 < end) { + uint8_t const byte2 = *(ptr + 1); + bool byte2_valid = (int8_t)byte2 <= (int8_t)0xBF; + bool byte3_valid = ((int8_t) * (ptr + 2)) <= (int8_t)0xBF; + bool byte4_valid = ((int8_t) * (ptr + 3)) <= (int8_t)0xBF; + if (byte2_valid && byte3_valid && byte4_valid && + // F0, 90..BF, 80..BF, 80..BF + ((byte == 0xF0 && byte2 >= 0x90) || + // F1..F3, 80..BF, 80..BF, 80..BF + (byte >= 0xF1 && byte <= 0xF3) || + // F4, 80..8F, 80..BF, 80..BF + (byte == 0xF4 && byte2 <= 0x8F))) { + ptr += 4; + } else { + return 0; + } + } + // Otherwise, invalid. + else { + return 0; + } + } + // If we got this far, we're valid. + return 1; +} + +#if defined(__x86_64__) && !defined(CRUFTY_GCC) + +// SSE2 + +static inline int is_valid_utf8_sse2(uint8_t const *const src, + size_t const len) { + uint8_t const *ptr = (uint8_t const *)src; + // This is 'one past the end' to make loop termination and bounds checks + // easier. + uint8_t const *const end = ptr + len; + while (ptr < end) { + uint8_t const byte = *ptr; + // Check if the byte is ASCII. + if (byte <= 0x7F) { + ptr++; + // If we saw one ASCII byte, as long as it's not whitespace, it's quite + // likely we'll see more. + bool is_not_whitespace = byte > 32; + // If possible, do a block-check ahead. + if ((ptr + 64 < end) && is_not_whitespace) { + __m128i const *big_ptr = (__m128i const *)ptr; + // Non-ASCII bytes have a set MSB. Thus, if we evacuate the MSBs, we + // will get a set bit somewhere if there's a non-ASCII byte in that + // block. + uint16_t result = _mm_movemask_epi8(_mm_loadu_si128(big_ptr)); + if (result == 0) { + ptr += 16; + // Try one more. + result = _mm_movemask_epi8(_mm_loadu_si128(big_ptr + 1)); + if (result == 0) { + ptr += 16; + // And one more. + result = _mm_movemask_epi8(_mm_loadu_si128(big_ptr + 2)); + if (result == 0) { + ptr += 16; + // Last one. + result = _mm_movemask_epi8(_mm_loadu_si128(big_ptr + 3)); + if (result == 0) { + ptr += 16; + } else { + ptr += __builtin_ctz(result); + } + } else { + ptr += __builtin_ctz(result); + } + } else { + ptr += __builtin_ctz(result); + } + } else { + ptr += __builtin_ctz(result); + } + } + } + // Check for a valid 2-byte sequence. + // + // We use a signed comparison to avoid an extra comparison with 0x80, since + // _signed_ 0x80 is -128. + else if (ptr + 1 < end && byte >= 0xC2 && byte <= 0xDF && + ((int8_t) * (ptr + 1)) <= (int8_t)0xBF) { + ptr += 2; + } + // Check for a valid 3-byte sequence. + else if (ptr + 2 < end) { + uint8_t const byte2 = *(ptr + 1); + bool byte2_valid = (int8_t)byte2 <= (int8_t)0xBF; + bool byte3_valid = ((int8_t) * (ptr + 2)) <= (int8_t)0xBF; + if (byte2_valid && byte3_valid && + // E0, A0..BF, 80..BF + ((byte == 0xE0 && byte2 >= 0xA0) || + // E1..EC, 80..BF, 80..BF + (byte >= 0xE1 && byte <= 0xEC) || + // ED, 80..9F, 80..BF + (byte == 0xED && byte2 <= 0x9F) || + // EE..EF, 80..BF, 80..BF + (byte >= 0xEE && byte <= 0xEF))) { + ptr += 3; + } else { + return 0; + } + } + // Check for a valid 4-byte sequence. + else if (ptr + 3 < end) { + uint8_t const byte2 = *(ptr + 1); + bool byte2_valid = (int8_t)byte2 <= (int8_t)0xBF; + bool byte3_valid = ((int8_t) * (ptr + 2)) <= (int8_t)0xBF; + bool byte4_valid = ((int8_t) * (ptr + 3)) <= (int8_t)0xBF; + if (byte2_valid && byte3_valid && byte4_valid && + // F0, 90..BF, 80..BF, 80..BF + ((byte == 0xF0 && byte2 >= 0x90) || + // F1..F3, 80..BF, 80..BF, 80..BF + (byte >= 0xF1 && byte <= 0xF3) || + // F4, 80..8F, 80..BF, 80..BF + (byte == 0xF4 && byte2 <= 0x8F))) { + ptr += 4; + } else { + return 0; + } + } + // Otherwise, invalid. + else { + return 0; + } + } + // If we got this far, we're valid. + return 1; +} + +// SSSE3 + +// Lookup tables + +// Map high nibble the first byte to legal character length minus 1 +// [0x00, 0xBF] --> 0 +// [0xC0, 0xDF] --> 1 +// [0xE0, 0xEF] --> 2 +// [0xF0, 0xFF] --> 3 +static int8_t const first_len_lookup[16] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 2, 3, +}; + +// Map first byte to 8th item of range table if it's in [0xC2, 0xF4] +static int8_t const first_range_lookup[16] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 8, 8, +}; + +// Range tables, mapping range index to min and max values +// Index 0 : 00 ~ 7F (First Byte, ascii) +// Index 1,2,3: 80 ~ BF (Second, Third, Fourth Byte) +// Index 4 : A0 ~ BF (Second Byte after E0) +// Index 5 : 80 ~ 9F (Second Byte after ED) +// Index 6 : 90 ~ BF (Second Byte after F0) +// Index 7 : 80 ~ 8F (Second Byte after F4) +// Index 8 : C2 ~ F4 (First Byte, non ascii) +// Index 9~15 : illegal: i >= 127 && i <= -128 +static int8_t const range_min_lookup[16] = { + 0x00, 0x80, 0x80, 0x80, 0xA0, 0x80, 0x90, 0x80, + 0xC2, 0x7F, 0x7F, 0x7F, 0x7F, 0x7F, 0x7F, 0x7F, +}; + +static int8_t const range_max_lookup[16] = { + 0x7F, 0xBF, 0xBF, 0xBF, 0xBF, 0x9F, 0xBF, 0x8F, + 0xF4, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, +}; + +// Tables for fast handling of four special First Bytes(E0,ED,F0,F4), after +// which the Second Byte are not 80~BF. It contains "range index adjustment". +// +------------+---------------+------------------+----------------+ +// | First Byte | original range| range adjustment | adjusted range | +// +------------+---------------+------------------+----------------+ +// | E0 | 2 | 2 | 4 | +// +------------+---------------+------------------+----------------+ +// | ED | 2 | 3 | 5 | +// +------------+---------------+------------------+----------------+ +// | F0 | 3 | 3 | 6 | +// +------------+---------------+------------------+----------------+ +// | F4 | 3 | 4 | 7 | +// +------------+---------------+------------------+----------------+ +// index1 -> E0, index14 -> ED +static int8_t const df_ee_lookup[16] = { + 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, +}; + +// index1 -> F0, index5 -> F4 +static int8_t const ef_fe_lookup[16] = { + 0, 3, 0, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, +}; + +__attribute__((target("ssse3"))) static inline bool +is_ascii_sse2(__m128i const *src, __m128i const prev_first_len) { + // Check if we have ASCII, and also that we don't have to treat the prior + // block as special. + // First, verify that we didn't see any non-ASCII bytes in the first half of + // the stride. + __m128i const first_half_clean = _mm_or_si128(src[0], src[1]); + // Then do the same for the second half of the stride. + __m128i const second_half_clean = _mm_or_si128(src[2], src[3]); + // Check cleanliness of the entire stride. + __m128i const stride_clean = + _mm_or_si128(first_half_clean, second_half_clean); + // Finally, check that we didn't have any leftover marker bytes in the + // previous block: these are indicated by non-zeroes in prev_first_len. In + // order to trigger a failure, we have to have non-zeros set the high bit of + // the lane: we do this by doing a greater-than comparison with a block of + // zeroes. + __m128i const no_prior_dirt = + _mm_cmpgt_epi8(prev_first_len, _mm_setzero_si128()); + // OR together everything, then check for a high bit anywhere. + __m128i const ored = _mm_or_si128(stride_clean, no_prior_dirt); + return (_mm_movemask_epi8(ored) == 0); +} + +__attribute__((target("ssse3"))) static inline __m128i +high_nibbles_of(__m128i const src) { + return _mm_and_si128(_mm_srli_epi16(src, 4), _mm_set1_epi8(0x0F)); +} + +__attribute__((target("ssse3"))) static inline __m128i +check_block_sse3(__m128i prev_input, __m128i prev_first_len, + __m128i const errors, __m128i const first_range_tbl, + __m128i const range_min_tbl, __m128i const range_max_tbl, + __m128i const df_ee_tbl, __m128i const ef_fe_tbl, + __m128i const input, __m128i const first_len) { + // Get the high 4-bits of the input. + __m128i const high_nibbles = + _mm_and_si128(_mm_srli_epi16(input, 4), _mm_set1_epi8(0x0F)); + // Set range index to 8 for bytes in [C0, FF] by lookup (first byte). + __m128i range = _mm_shuffle_epi8(first_range_tbl, high_nibbles); + // Reduce the range index based on first_len (second byte) + // This is 0 for [00, 7F], 1 for [C0, DF], 2 for [E0, EF], 3 for [F0, FF]. + range = _mm_or_si128(range, _mm_alignr_epi8(first_len, prev_first_len, 15)); + // Set range index to the saturation of (first_len - 1) (third byte). + // This is 0 for [00, 7F], 0 for [C0, DF], 1 for [E0, EF], 2 for [F0, FF]. + __m128i tmp = _mm_alignr_epi8(first_len, prev_first_len, 14); + tmp = _mm_subs_epu8(tmp, _mm_set1_epi8(1)); + range = _mm_or_si128(range, tmp); + // Set range index to the saturation of (first_len - 2) (fourth byte). + // This is 0 for [00, 7F], 0 for [C0, DF], 0 for [E0, EF] and 1 for [F0, FF]. + tmp = _mm_alignr_epi8(first_len, prev_first_len, 13); + tmp = _mm_subs_epu8(tmp, _mm_set1_epi8(2)); + range = _mm_or_si128(range, tmp); + // At this stage, we have calculated range indices correctly, except for + // special cases for first bytes (E0, ED, F0, F4). We repair this to avoid + // missing in the range table. + __m128i const shift1 = _mm_alignr_epi8(input, prev_input, 15); + __m128i const pos = _mm_sub_epi8(shift1, _mm_set1_epi8(0xEF)); + tmp = _mm_subs_epu8(pos, _mm_set1_epi8(0xF0)); + __m128i range2 = _mm_shuffle_epi8(df_ee_tbl, tmp); + tmp = _mm_adds_epu8(pos, _mm_set1_epi8(0x70)); + range2 = _mm_add_epi8(range2, _mm_shuffle_epi8(ef_fe_tbl, tmp)); + range = _mm_add_epi8(range, range2); + // We can now load minimum and maximum values from our tables based on the + // calculated indices. + __m128i const minv = _mm_shuffle_epi8(range_min_tbl, range); + __m128i const maxv = _mm_shuffle_epi8(range_max_tbl, range); + // Calculate the error (if any). + tmp = _mm_or_si128(_mm_cmplt_epi8(input, minv), _mm_cmpgt_epi8(input, maxv)); + // Accumulate error. + return _mm_or_si128(errors, tmp); +} + +__attribute__((target("ssse3"))) static inline int +is_valid_utf8_ssse3(uint8_t const *const src, size_t const len) { + // We stride 64 bytes at a time. + size_t const big_strides = len / 64; + size_t const remaining = len % 64; + uint8_t const *ptr = (uint8_t const *)src; + // Tracking state. + __m128i prev_input = _mm_setzero_si128(); + __m128i prev_first_len = _mm_setzero_si128(); + __m128i errors = _mm_setzero_si128(); + for (size_t i = 0; i < big_strides; i++) { + // Pre-load tables. + __m128i const first_len_tbl = + _mm_loadu_si128((__m128i const *)first_len_lookup); + __m128i const first_range_tbl = + _mm_loadu_si128((__m128i const *)first_range_lookup); + __m128i const range_min_tbl = + _mm_loadu_si128((__m128i const *)range_min_lookup); + __m128i const range_max_tbl = + _mm_loadu_si128((__m128i const *)range_max_lookup); + __m128i const df_ee_tbl = _mm_loadu_si128((__m128i const *)df_ee_lookup); + __m128i const ef_fe_tbl = _mm_loadu_si128((__m128i const *)ef_fe_lookup); + // Load 64 bytes. + __m128i const *big_ptr = (__m128i const *)ptr; + __m128i const inputs[4] = { + _mm_loadu_si128(big_ptr), _mm_loadu_si128(big_ptr + 1), + _mm_loadu_si128(big_ptr + 2), _mm_loadu_si128(big_ptr + 3)}; + // Check if we have ASCII. + if (is_ascii_sse2(inputs, prev_first_len)) { + // Prev_first_len cheaply. + prev_first_len = + _mm_shuffle_epi8(first_len_tbl, high_nibbles_of(inputs[3])); + } else { + __m128i first_len = + _mm_shuffle_epi8(first_len_tbl, high_nibbles_of(inputs[0])); + errors = check_block_sse3(prev_input, prev_first_len, errors, + first_range_tbl, range_min_tbl, range_max_tbl, + df_ee_tbl, ef_fe_tbl, inputs[0], first_len); + prev_first_len = first_len; + first_len = _mm_shuffle_epi8(first_len_tbl, high_nibbles_of(inputs[1])); + errors = check_block_sse3(inputs[0], prev_first_len, errors, + first_range_tbl, range_min_tbl, range_max_tbl, + df_ee_tbl, ef_fe_tbl, inputs[1], first_len); + prev_first_len = first_len; + first_len = _mm_shuffle_epi8(first_len_tbl, high_nibbles_of(inputs[2])); + errors = check_block_sse3(inputs[1], prev_first_len, errors, + first_range_tbl, range_min_tbl, range_max_tbl, + df_ee_tbl, ef_fe_tbl, inputs[2], first_len); + prev_first_len = first_len; + first_len = _mm_shuffle_epi8(first_len_tbl, high_nibbles_of(inputs[3])); + errors = check_block_sse3(inputs[2], prev_first_len, errors, + first_range_tbl, range_min_tbl, range_max_tbl, + df_ee_tbl, ef_fe_tbl, inputs[3], first_len); + prev_first_len = first_len; + } + // Set prev_input based on last block. + prev_input = inputs[3]; + // Advance. + ptr += 64; + } + // Write out the error, check if it's OK. + uint64_t results[2]; + _mm_storeu_si128((__m128i *)results, errors); + if (results[0] != 0 || results[1] != 0) { + return 0; + } + // 'Roll back' our pointer a little to prepare for a slow search of the rest. + uint16_t tokens[2]; + tokens[0] = _mm_extract_epi16(prev_input, 6); + tokens[1] = _mm_extract_epi16(prev_input, 7); + uint8_t const *token_ptr = (uint8_t const *)tokens; + ptrdiff_t rollback = 0; + // We must not roll back if no big blocks were processed, as then + // the fallback function would examine out-of-bounds data (#620). + // In that case, prev_input contains only nulls and we skip the if body. + if (token_ptr[3] >= 0x80u) { + // Look for an incomplete multi-byte code point + if (token_ptr[3] >= 0xC0u) { + rollback = 1; + } else if (token_ptr[2] >= 0xE0u) { + rollback = 2; + } else if (token_ptr[1] >= 0xF0u) { + rollback = 3; + } + } + // Finish the job. + uint8_t const *const small_ptr = ptr - rollback; + size_t const small_len = remaining + rollback; + return is_valid_utf8_fallback(small_ptr, small_len); +} + +// AVX2 +// +// These work similarly to the SSSE3 version, but with registers twice the +// width. + +static int8_t const first_len_lookup2[32] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 2, 3, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 2, 3, +}; + +static int8_t const first_range_lookup2[32] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 8, 8, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 8, 8, +}; + +static int8_t const range_min_lookup2[32] = { + 0x00, 0x80, 0x80, 0x80, 0xA0, 0x80, 0x90, 0x80, 0xC2, 0x7F, 0x7F, + 0x7F, 0x7F, 0x7F, 0x7F, 0x7F, 0x00, 0x80, 0x80, 0x80, 0xA0, 0x80, + 0x90, 0x80, 0xC2, 0x7F, 0x7F, 0x7F, 0x7F, 0x7F, 0x7F, 0x7F, +}; + +static int8_t const range_max_lookup2[32] = { + 0x7F, 0xBF, 0xBF, 0xBF, 0xBF, 0x9F, 0xBF, 0x8F, 0xF4, 0x80, 0x80, + 0x80, 0x80, 0x80, 0x80, 0x80, 0x7F, 0xBF, 0xBF, 0xBF, 0xBF, 0x9F, + 0xBF, 0x8F, 0xF4, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, +}; + +static int8_t const df_ee_lookup2[32] = { + 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, + 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, +}; + +static int8_t const ef_fe_lookup2[32] = { + 0, 3, 0, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 3, 0, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, +}; + +__attribute__((target("avx,avx2"))) static inline __m256i +high_nibbles_of_avx2(__m256i const src) { + return _mm256_and_si256(_mm256_srli_epi16(src, 4), _mm256_set1_epi8(0x0F)); +} + +__attribute__((target("avx,avx2"))) static inline __m256i +push_last_byte_of_a_to_b(__m256i const a, __m256i const b) { + return _mm256_alignr_epi8(b, _mm256_permute2x128_si256(a, b, 0x21), 15); +} + +__attribute__((target("avx,avx2"))) static inline __m256i +push_last_2bytes_of_a_to_b(__m256i const a, __m256i const b) { + return _mm256_alignr_epi8(b, _mm256_permute2x128_si256(a, b, 0x21), 14); +} + +__attribute__((target("avx,avx2"))) static inline __m256i +push_last_3bytes_of_a_to_b(__m256i const a, __m256i const b) { + return _mm256_alignr_epi8(b, _mm256_permute2x128_si256(a, b, 0x21), 13); +} + +__attribute__((target("avx,avx2"))) static inline void +check_block_avx2(__m256i const prev_input, __m256i const prev_first_len, + __m256i *errors, __m256i const first_range_tbl, + __m256i const range_min_tbl, __m256i const range_max_tbl, + __m256i const df_ee_tbl, __m256i const ef_fe_tbl, + __m256i const input, __m256i const first_len) { + // Set range index to 8 for bytes in [C0, FF] by lookup (first byte). + __m256i range = + _mm256_shuffle_epi8(first_range_tbl, high_nibbles_of_avx2(input)); + // Reduce the range index based on first_len (second byte) + // This is 0 for [00, 7F], 1 for [C0, DF], 2 for [E0, EF], 3 for [F0, FF]. + range = _mm256_or_si256(range, + push_last_byte_of_a_to_b(prev_first_len, first_len)); + // Set range index to the saturation of (first_len - 1) (third byte). + // This is 0 for [00, 7F], 0 for [C0, DF], 1 for [E0, EF], 2 for [F0, FF]. + __m256i tmp1 = push_last_2bytes_of_a_to_b(prev_first_len, first_len); + __m256i tmp2 = _mm256_subs_epu8(tmp1, _mm256_set1_epi8(0x01)); + range = _mm256_or_si256(range, tmp2); + // Set range index to the saturation of (first_len - 2) (fourth byte). + tmp1 = push_last_3bytes_of_a_to_b(prev_first_len, first_len); + tmp2 = _mm256_subs_epu8(tmp1, _mm256_set1_epi8(0x02)); + range = _mm256_or_si256(range, tmp2); + // At this stage, we have calculated range indices correctly, except for + // special cases for first bytes (E0, ED, F0, F4). We repair this to avoid + // missing in the range table. + __m256i const shift1 = push_last_byte_of_a_to_b(prev_input, input); + __m256i pos = _mm256_sub_epi8(shift1, _mm256_set1_epi8(0xEF)); + tmp1 = _mm256_subs_epu8(pos, _mm256_set1_epi8(0xF0)); + __m256i range2 = _mm256_shuffle_epi8(df_ee_tbl, tmp1); + tmp2 = _mm256_adds_epu8(pos, _mm256_set1_epi8(0x70)); + range2 = _mm256_add_epi8(range2, _mm256_shuffle_epi8(ef_fe_tbl, tmp2)); + range = _mm256_add_epi8(range, range2); + // We can now load minimum and maximum values from our tables based on the + // calculated indices. + __m256i const minv = _mm256_shuffle_epi8(range_min_tbl, range); + __m256i const maxv = _mm256_shuffle_epi8(range_max_tbl, range); + // Calculate the error, if any. + errors[0] = _mm256_or_si256(errors[0], _mm256_cmpgt_epi8(minv, input)); + errors[1] = _mm256_or_si256(errors[1], _mm256_cmpgt_epi8(input, maxv)); +} + +__attribute__((target("avx,avx2"))) static inline int +is_valid_utf8_avx2(uint8_t const *const src, size_t const len) { + // We stride 128 bytes at a time. + size_t const big_strides = len / 128; + size_t const remaining = len % 128; + uint8_t const *ptr = (uint8_t const *)src; + // Tracking state. + __m256i prev_input = _mm256_setzero_si256(); + __m256i prev_first_len = _mm256_setzero_si256(); + __m256i errors[2] = {_mm256_setzero_si256(), _mm256_setzero_si256()}; + for (size_t i = 0; i < big_strides; i++) { + // Pre-load tables. + __m256i const first_len_tbl = + _mm256_loadu_si256((__m256i const *)first_len_lookup2); + __m256i const first_range_tbl = + _mm256_loadu_si256((__m256i const *)first_range_lookup2); + __m256i const range_min_tbl = + _mm256_loadu_si256((__m256i const *)range_min_lookup2); + __m256i const range_max_tbl = + _mm256_loadu_si256((__m256i const *)range_max_lookup2); + __m256i const df_ee_tbl = + _mm256_loadu_si256((__m256i const *)df_ee_lookup2); + __m256i const ef_fe_tbl = + _mm256_loadu_si256((__m256i const *)ef_fe_lookup2); + // Load 128 bytes. + __m256i const *big_ptr = (__m256i const *)ptr; + __m256i const inputs[4] = { + _mm256_loadu_si256(big_ptr), _mm256_loadu_si256(big_ptr + 1), + _mm256_loadu_si256(big_ptr + 2), _mm256_loadu_si256(big_ptr + 3)}; + // Check if we have ASCII, and also that we don't have to treat the prior + // block as special. + // First, verify that we didn't see any non-ASCII bytes in the first half of + // the stride. + __m256i const first_half_clean = _mm256_or_si256(inputs[0], inputs[1]); + // Then do the same for the second half of the stride. + __m256i const second_half_clean = _mm256_or_si256(inputs[2], inputs[3]); + // Check cleanliness of the entire stride. + __m256i const stride_clean = + _mm256_or_si256(first_half_clean, second_half_clean); + // Finally, check that we didn't have any leftover marker bytes in the + // previous block: these are indicated by non-zeroes in prev_first_len. + // In order to trigger a failure, we have to have non-zeros set the high bit + // of the lane: we do this by doing a greater-than comparison with a block + // of zeroes. + __m256i const no_prior_dirt = + _mm256_cmpgt_epi8(prev_first_len, _mm256_setzero_si256()); + // Combine all checks together, and check if any high bits are set. + bool is_ascii = + _mm256_movemask_epi8(_mm256_or_si256(stride_clean, no_prior_dirt)) == 0; + if (is_ascii) { + // Prev_first_len cheaply + prev_first_len = + _mm256_shuffle_epi8(first_len_tbl, high_nibbles_of_avx2(inputs[3])); + } else { + __m256i first_len = + _mm256_shuffle_epi8(first_len_tbl, high_nibbles_of_avx2(inputs[0])); + check_block_avx2(prev_input, prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, df_ee_tbl, ef_fe_tbl, + inputs[0], first_len); + prev_first_len = first_len; + first_len = + _mm256_shuffle_epi8(first_len_tbl, high_nibbles_of_avx2(inputs[1])); + check_block_avx2(inputs[0], prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, df_ee_tbl, ef_fe_tbl, + inputs[1], first_len); + prev_first_len = first_len; + first_len = + _mm256_shuffle_epi8(first_len_tbl, high_nibbles_of_avx2(inputs[2])); + check_block_avx2(inputs[1], prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, df_ee_tbl, ef_fe_tbl, + inputs[2], first_len); + prev_first_len = first_len; + first_len = + _mm256_shuffle_epi8(first_len_tbl, high_nibbles_of_avx2(inputs[3])); + check_block_avx2(inputs[2], prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, df_ee_tbl, ef_fe_tbl, + inputs[3], first_len); + prev_first_len = first_len; + } + // Set prev_input based on last block. + prev_input = inputs[3]; + // Advance. + ptr += 128; + } + // Write out the error, check if it's OK. + __m256i const combined_errors = _mm256_or_si256(errors[0], errors[1]); + if (_mm256_testz_si256(combined_errors, combined_errors) != 1) { + return 0; + } + // 'Roll back' our pointer a little to prepare for a slow search of the rest. + uint32_t tokens_blob = _mm256_extract_epi32(prev_input, 7); + uint8_t const *token_ptr = (uint8_t const *)&tokens_blob; + ptrdiff_t rollback = 0; + // We must not roll back if no big blocks were processed, as then + // the fallback function would examine out-of-bounds data (#620). + // In that case, prev_input contains only nulls and we skip the if body. + if (token_ptr[3] >= 0x80u) { + // Look for an incomplete multi-byte code point + if (token_ptr[3] >= 0xC0u) { + rollback = 1; + } else if (token_ptr[2] >= 0xE0u) { + rollback = 2; + } else if (token_ptr[1] >= 0xF0u) { + rollback = 3; + } + } + // Finish the job. + uint8_t const *const small_ptr = ptr - rollback; + size_t const small_len = remaining + rollback; + return is_valid_utf8_fallback(small_ptr, small_len); +} + +#endif + +#if defined(__x86_64__) && !defined(CRUFTY_GCC) +static inline bool has_sse2() { + uint32_t eax = 0, ebx = 0, ecx = 0, edx = 0; + __get_cpuid_count(1, 0, &eax, &ebx, &ecx, &edx); + // https://en.wikipedia.org/wiki/CPUID#EAX=1:_Processor_Info_and_Feature_Bits + return edx & (1 << 26); +} + +static inline bool has_ssse3() { + uint32_t eax = 0, ebx = 0, ecx = 0, edx = 0; + __get_cpuid_count(1, 0, &eax, &ebx, &ecx, &edx); + // https://en.wikipedia.org/wiki/CPUID#EAX=1:_Processor_Info_and_Feature_Bits + return ecx & (1 << 9); +} + +static inline bool has_avx2() { + uint32_t eax = 0, ebx = 0, ecx = 0, edx = 0; + __get_cpuid_count(7, 0, &eax, &ebx, &ecx, &edx); + // https://en.wikipedia.org/wiki/CPUID#EAX=7,_ECX=0:_Extended_Features + return ebx & (1 << 5); +} +#endif + +typedef int (*is_valid_utf8_t)(uint8_t const *const, size_t const); + +int bytestring_is_valid_utf8(uint8_t const *const src, size_t const len) { + if (len == 0) { + return 1; + } +#if defined(__x86_64__) && !defined(CRUFTY_GCC) + static _Atomic is_valid_utf8_t s_impl = (is_valid_utf8_t)NULL; + is_valid_utf8_t impl = atomic_load_explicit(&s_impl, memory_order_relaxed); + if (!impl) { + impl = has_avx2() ? is_valid_utf8_avx2 + : (has_ssse3() ? is_valid_utf8_ssse3 + : (has_sse2() ? is_valid_utf8_sse2 + : is_valid_utf8_fallback)); + atomic_store_explicit(&s_impl, impl, memory_order_relaxed); + } + return (*impl)(src, len); +#else + return is_valid_utf8_fallback(src, len); +#endif +} + +#pragma GCC pop_options diff --git a/cbits/itoa.c b/cbits/itoa.c --- a/cbits/itoa.c +++ b/cbits/itoa.c @@ -9,7 +9,7 @@ // Decimal Encoding /////////////////// -const char* digits = "0123456789abcdef"; +static const char* digits = "0123456789abcdef"; // signed integers char* _hs_bytestring_int_dec (int x, char* buf) @@ -127,6 +127,50 @@ *buf++ = c; } return next_free; +} + + +// Padded, decimal, positive integers for the decimal output of bignums +/////////////////////////////////////////////////////////////////////// + +// Padded (9 digits), decimal, positive int: +// We will use it with numbers that fit in 31 bits; i.e., numbers smaller than +// 10^9, as "31 * log 2 / log 10 = 9.33" +void _hs_bytestring_int_dec_padded9 (int x, char* buf) +{ + const int max_width_int32_dec = 9; + char* ptr = buf + max_width_int32_dec; + int x_tmp; + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *(--ptr) = digits[x_tmp - x * 10]; + } while ( x ); + + // pad beginning + while (buf < ptr) { *(--ptr) = '0'; } +} + +// Padded (19 digits), decimal, positive long long int: +// We will use it with numbers that fit in 63 bits; i.e., numbers smaller than +// 10^18, as "63 * log 2 / log 10 = 18.96" +void _hs_bytestring_long_long_int_dec_padded18 (long long int x, char* buf) +{ + const int max_width_int64_dec = 18; + char* ptr = buf + max_width_int64_dec; + long long int x_tmp; + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *(--ptr) = digits[x_tmp - x * 10]; + } while ( x ); + + // pad beginning + while (buf < ptr) { *(--ptr) = '0'; } } diff --git a/cbits/shortbytestring.c b/cbits/shortbytestring.c new file mode 100644 --- /dev/null +++ b/cbits/shortbytestring.c @@ -0,0 +1,21 @@ +#include +#include +#include +#include + + +ptrdiff_t +sbs_elem_index(const void *s, + uint8_t c, + size_t n) +{ + const void *so = memchr(s, c, n); + + if (so) { + ptrdiff_t diff = so - s; + assert(diff >= 0); + return diff; + } else { + return -1; + } +} diff --git a/include/bytestring-cpp-macros.h b/include/bytestring-cpp-macros.h new file mode 100644 --- /dev/null +++ b/include/bytestring-cpp-macros.h @@ -0,0 +1,50 @@ +#if defined(__STDC__) || defined(__GNUC__) || defined(__clang__) +#error "bytestring-cpp-macros.h does not work in C code yet" +#endif + + +#if defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH) \ + || ((defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)) \ + && defined(__ARM_FEATURE_UNALIGNED)) \ + || defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH) \ + || defined(powerpc64le_HOST_ARCH) \ + || defined(javascript_HOST_ARCH) +/* +Not all architectures are forgiving of unaligned accesses; whitelist ones +which are known not to trap (either to the kernel for emulation, or crash). +*/ +#define HS_UNALIGNED_POKES_OK 1 +#else +#if PURE_HASKELL +#error "-fpure-haskell isn't supported yet on architectures only supporting aligned accesses." +#endif +#define HS_UNALIGNED_POKES_OK 0 +#endif + + +#define HS_UNALIGNED_ByteArray_OPS_OK \ + MIN_VERSION_base(4,12,0) \ + && (MIN_VERSION_base(4,16,1) || HS_UNALIGNED_POKES_OK) +/* +The unaligned ByteArray# primops became available with base-4.12.0/ghc-8.6, +but require an unaligned-friendly host architecture to be safe to use +until ghc-9.2.2; see https://gitlab.haskell.org/ghc/ghc/-/issues/21015 +*/ + + +#define HS_CAST_FLOAT_WORD_OPS_AVAILABLE MIN_VERSION_base(4,14,0) +/* +These operations were added in base-4.10.0, but due to +https://gitlab.haskell.org/ghc/ghc/-/issues/16617 they +are buggy with negative floats before ghc-8.10. +*/ + +#define HS_UNALIGNED_ADDR_PRIMOPS_AVAILABLE MIN_VERSION_base(4,20,0) + +#define HS_timesInt2_PRIMOP_AVAILABLE MIN_VERSION_base(4,15,0) + +#define HS_cstringLength_AND_FinalPtr_AVAILABLE MIN_VERSION_base(4,15,0) + /* These two were added in the same ghc commit and + both primarily affect how we handle literals */ + +#define HS_unsafeWithForeignPtr_AVAILABLE MIN_VERSION_base(4,15,0) diff --git a/include/fpstring.h b/include/fpstring.h --- a/include/fpstring.h +++ b/include/fpstring.h @@ -1,9 +1,9 @@ - #include - -void fps_reverse(unsigned char *dest, unsigned char *from, unsigned long len); -void fps_intersperse(unsigned char *dest, unsigned char *from, unsigned long len, unsigned char c); -unsigned char fps_maximum(unsigned char *p, unsigned long len); -unsigned char fps_minimum(unsigned char *p, unsigned long len); -unsigned long fps_count(unsigned char *p, unsigned long len, unsigned char w); +#include +void fps_reverse(unsigned char *dest, unsigned char *from, size_t len); +void fps_intersperse(unsigned char *dest, unsigned char *from, size_t len, unsigned char c); +unsigned char fps_maximum(unsigned char *p, size_t len); +unsigned char fps_minimum(unsigned char *p, size_t len); +size_t fps_count(unsigned char *p, size_t len, unsigned char w); +void fps_sort(unsigned char *p, size_t len); diff --git a/tests/Builder.hs b/tests/Builder.hs new file mode 100644 --- /dev/null +++ b/tests/Builder.hs @@ -0,0 +1,14 @@ +module Builder (testSuite) where + +import qualified Data.ByteString.Builder.Tests +import qualified Data.ByteString.Builder.Prim.Tests +import Test.Tasty (TestTree, testGroup) + +testSuite :: TestTree +testSuite = testGroup "Builder" + [ testGroup "Data.ByteString.Builder" + Data.ByteString.Builder.Tests.tests + + , testGroup "Data.ByteString.Builder.BasicEncoding" + Data.ByteString.Builder.Prim.Tests.tests + ] diff --git a/tests/IsValidUtf8.hs b/tests/IsValidUtf8.hs new file mode 100644 --- /dev/null +++ b/tests/IsValidUtf8.hs @@ -0,0 +1,364 @@ +module IsValidUtf8 (testSuite) where + +import Data.Bits (shiftR, (.&.), shiftL) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Short as SBS +import qualified Data.ByteString as B +import Data.Char (chr, ord) +import Data.Word (Word8) +import Control.Monad (guard) +import Numeric (showHex) +import GHC.Exts (fromList, fromListN, toList) +import Test.QuickCheck (Property, forAll, (===), forAllShrinkShow) +import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary, shrink)) +import Test.QuickCheck.Gen (oneof, Gen, choose, vectorOf, listOf1, sized, resize, + elements, choose) +import Test.Tasty (testGroup, adjustOption, TestTree) +import Test.Tasty.QuickCheck (testProperty, QuickCheckTests) + +testSuite :: TestTree +testSuite = testGroup "UTF-8 validation" [ + adjustOption (max testCount) . testProperty "Valid UTF-8 ByteString" $ goValidBS, + adjustOption (max testCount) . testProperty "Invalid UTF-8 ByteString" $ goInvalidBS, + adjustOption (max testCount) . testProperty "Valid UTF-8 ShortByteString" $ goValidSBS, + adjustOption (max testCount) . testProperty "Invalid UTF-8 ShortByteString" $ goInvalidSBS, + testGroup "Regressions" checkRegressions + ] + where + goValidBS :: ValidUtf8 -> Bool + goValidBS = B.isValidUtf8 . foldMap sequenceToBS . unValidUtf8 + goInvalidBS :: InvalidUtf8 -> Bool + goInvalidBS = not . B.isValidUtf8 . toByteString + goValidSBS :: ValidUtf8 -> Bool + goValidSBS = SBS.isValidUtf8 . SBS.toShort . foldMap sequenceToBS . unValidUtf8 + goInvalidSBS :: InvalidUtf8 -> Bool + goInvalidSBS = not . SBS.isValidUtf8 . SBS.toShort . toByteString + testCount :: QuickCheckTests + testCount = 1000 + +checkRegressions :: [TestTree] +checkRegressions = [ + testProperty "Too high code point" $ + not $ B.isValidUtf8 tooHigh, + testProperty "Invalid byte at end of ASCII block" badBlockEnd, + testProperty "Invalid byte between spaces" $ + not $ B.isValidUtf8 byteBetweenSpaces, + testProperty "Two invalid bytes between spaces" $ + not $ B.isValidUtf8 twoBytesBetweenSpaces, + testProperty "Three invalid bytes between spaces" $ + not $ B.isValidUtf8 threeBytesBetweenSpaces, + testProperty "ASCII stride and invalid multibyte sequence" $ + not $ B.isValidUtf8 asciiAndInvalidMultiByte, + testProperty "Splitting valid in two" splitValid + ] + where + tooHigh :: ByteString + tooHigh = fromList $ replicate 56 48 ++ -- 56 ASCII zeroes + [244, 176, 181, 139] ++ -- our invalid sequence too high to be valid + (take 68 . cycle $ [194, 162]) -- 68 cent symbols + + byteBetweenSpaces :: ByteString + byteBetweenSpaces = fromList $ replicate 127 32 ++ [216] ++ replicate 128 32 + + twoBytesBetweenSpaces :: ByteString + twoBytesBetweenSpaces = fromList $ replicate 126 32 ++ [235, 167] ++ replicate 128 32 + + threeBytesBetweenSpaces :: ByteString + threeBytesBetweenSpaces = fromList $ replicate 125 32 ++ [242, 134, 159] ++ replicate 128 32 + + badBlockEnd :: Property + badBlockEnd = + forAllShrinkShow genBadBlock shrinkBadBlock showBadBlock $ \(BadBlock bs) -> + not . B.isValidUtf8 $ bs + + asciiAndInvalidMultiByte :: ByteString + asciiAndInvalidMultiByte = fromList $ replicate 32 48 ++ [235, 185] + + splitValid :: Property + splitValid = forAll genValidUtf8 $ \bs -> + forAll (choose (0, B.length bs)) $ \k -> + case B.splitAt k bs of + -- q may have non-zero offset, which + -- allows this property test to tickle #620 + (p, q) -> B.isValidUtf8 p == B.isValidUtf8 q + +-- Helpers + +-- A 128-byte sequence with a single bad byte at the end, with the rest being +-- ASCII +newtype BadBlock = BadBlock ByteString + +genBadBlock :: Gen BadBlock +genBadBlock = do + asciiBytes <- vectorOf 127 $ choose (0, 127) + pure . BadBlock . fromListN 128 $ asciiBytes ++ [216] + +shrinkBadBlock :: BadBlock -> [BadBlock] +shrinkBadBlock (BadBlock bs) = BadBlock <$> do + let asList = init . toList $ bs + init' <- fromList <$> traverse shrink asList + guard (B.length init' == 127) + pure . B.append init' . B.singleton $ 216 + +-- Display as hex instead of ASCII-ish +showBadBlock :: BadBlock -> String +showBadBlock (BadBlock bs) = let asList = toList bs in + foldr showHex "" asList + +data Utf8Sequence = + One Word8 | + Two Word8 Word8 | + Three Word8 Word8 Word8 | + Four Word8 Word8 Word8 Word8 + deriving (Eq) + +instance Arbitrary Utf8Sequence where + arbitrary = oneof [ + One <$> elements [0x00 .. 0x7F], + Two <$> elements [0xC2 .. 0xDF] <*> elements [0x80 .. 0xBF], + genThree, + genFour + ] + where + genThree :: Gen Utf8Sequence + genThree = do + w1 <- elements [0xE0 .. 0xED] + w2 <- elements $ case w1 of + 0xE0 -> [0xA0 .. 0xBF] + 0xED -> [0x80 .. 0x9F] + _ -> [0x80 .. 0xBF] + w3 <- elements [0x80 .. 0xBF] + pure . Three w1 w2 $ w3 + genFour :: Gen Utf8Sequence + genFour = do + w1 <- elements [0xF0 .. 0xF4] + w2 <- elements $ case w1 of + 0xF0 -> [0x90 .. 0xBF] + 0xF4 -> [0x80 .. 0x8F] + _ -> [0x80 .. 0xBF] + w3 <- elements [0x80 .. 0xBF] + w4 <- elements [0x80 .. 0xBF] + pure . Four w1 w2 w3 $ w4 + shrink = \case + One w1 -> One <$> case w1 of + 0x00 -> [] + _ -> [0x00 .. (w1 - 1)] + Two w1 w2 -> case (w1, w2) of + (0xC2, 0x80) -> allOnes + _ -> (Two <$> [0xC2 .. (w1 - 1)] <*> [0x80 .. (w2 - 1)]) ++ allOnes + Three w1 w2 w3 -> case (w1, w2, w3) of + (0xE0, 0xA0, 0x80) -> allTwos ++ allOnes + (0xE0, 0xA0, _) -> (Three 0xE0 0xA0 <$> [0x80 .. (w3 - 1)]) ++ allTwos ++ allOnes + (0xE0, _, _) -> + (Three 0xE0 <$> [0xA0 .. (w2 - 1)] <*> [0x80 .. (w3 - 1)]) ++ allTwos ++ allOnes + _ -> do + w1' <- [0xE0 .. (w1 - 1)] + case w1' of + 0xE0 -> (Three 0xE0 <$> [0xA0 .. 0xBF] <*> [0x80 .. 0xBF]) ++ + allTwos ++ + allOnes + _ -> (Three w1' <$> [0x80 .. 0xBF] <*> [0x80 .. 0xBF]) ++ + allTwos ++ + allOnes + Four w1 w2 w3 w4 -> case (w1, w2, w3, w4) of + (0xF0, 0x90, 0x80, 0x80) -> allThrees ++ allTwos ++ allOnes + (0xF0, 0x90, 0x80, _) -> + (Four 0xF0 0x90 0x80 <$> [0x80 .. (w4 - 1)]) ++ + allThrees ++ + allTwos ++ + allOnes + (0xF0, 0x90, _, _) -> + (Four 0xF0 0x90 <$> [0x80 .. (w3 - 1)] <*> [0x80 .. (w4 - 1)]) ++ + allThrees ++ + allTwos ++ + allOnes + (0xF0, _, _, _) -> + (Four 0xF0 <$> [0x90 .. (w2 - 1)] <*> [0x80 .. (w3 - 1)] <*> [0x80 .. (w4 - 1)]) ++ + allThrees ++ + allTwos ++ + allOnes + _ -> do + w1' <- [0xF0 .. (w1 - 1)] + case w1' of + 0xF0 -> (Four 0xF0 <$> [0x90 .. 0xBF] <*> [0x80 .. 0xBF] <*> [0x80 .. 0xBF]) ++ + allThrees ++ + allTwos ++ + allOnes + _ -> (Four w1' <$> [0x80 .. 0xBF] <*> [0x80 .. 0xBF] <*> [0x80 .. 0xBF]) ++ + allThrees ++ + allTwos ++ + allOnes + +allOnes :: [Utf8Sequence] +allOnes = One <$> [0x00 .. 0x7F] + +allTwos :: [Utf8Sequence] +allTwos = Two <$> [0xC2 .. 0xDF] <*> [0x80 .. 0xBF] + +allThrees :: [Utf8Sequence] +allThrees = (Three 0xE0 <$> [0xA0 .. 0xBF] <*> [0x80 .. 0xBF]) ++ + (Three 0xED <$> [0x80 .. 0x9F] <*> [0x80 .. 0xBF]) ++ + (Three <$> [0xE1 .. 0xEC] <*> [0x80 .. 0xBF] <*> [0x80 .. 0xBF]) ++ + (Three <$> [0xEE .. 0xEF] <*> [0x80 .. 0xBF] <*> [0x80 .. 0xBF]) + +sequenceToBS :: Utf8Sequence -> ByteString +sequenceToBS = B.pack . \case + One w1 -> [w1] + Two w1 w2 -> [w1, w2] + Three w1 w2 w3 -> [w1, w2, w3] + Four w1 w2 w3 w4 -> [w1, w2, w3, w4] + +newtype ValidUtf8 = ValidUtf8 { unValidUtf8 :: [Utf8Sequence] } + deriving (Eq) + +instance Show ValidUtf8 where + show (ValidUtf8 ss) = show . foldMap sequenceToBS $ ss + +instance Arbitrary ValidUtf8 where + arbitrary = ValidUtf8 <$> arbitrary + shrink (ValidUtf8 ss) = ValidUtf8 <$> shrink ss + +data InvalidUtf8 = InvalidUtf8 { + prefix :: ByteString, + invalid :: ByteString, + suffix :: ByteString + } + deriving (Eq) + +instance Show InvalidUtf8 where + show i = "InvalidUtf8 {prefix = " ++ show (prefix i) + ++ ", invalid = " ++ show (invalid i) + ++ ", suffix = " ++ show (suffix i) + ++ ", asBS = " ++ show (toByteString i) + ++ ", length = " ++ show (B.length . toByteString $ i) + ++ "}" + +instance Arbitrary InvalidUtf8 where + arbitrary = oneof + [ InvalidUtf8 mempty <$> genInvalidUtf8 <*> pure mempty + , InvalidUtf8 mempty <$> genInvalidUtf8 <*> genValidUtf8 + , InvalidUtf8 <$> genValidUtf8 <*> genInvalidUtf8 <*> pure mempty + , InvalidUtf8 <$> genValidUtf8 <*> genInvalidUtf8 <*> genValidUtf8 + ] + shrink (InvalidUtf8 p i s) = + (InvalidUtf8 p i <$> shrinkValidBS s) ++ + ((\p' -> InvalidUtf8 p' i s) <$> shrinkValidBS p) + +toByteString :: InvalidUtf8 -> ByteString +toByteString (InvalidUtf8 p i s) = p `B.append` i `B.append` s + +genInvalidUtf8 :: Gen ByteString +genInvalidUtf8 = B.pack <$> oneof [ + -- invalid leading byte of a 2-byte sequence + (:) <$> choose (0xC0, 0xC1) <*> upTo 1 contByte + -- invalid leading byte of a 4-byte sequence + , (:) <$> choose (0xF5, 0xFF) <*> upTo 3 contByte + -- 4-byte sequence greater than U+10FFF + , do k <- choose (0x11, 0x13) + let w0 = 0xF0 + (k `shiftR` 2) + let w1 = 0x80 + ((k .&. 3) `shiftL` 4) + ([w0, w1] ++) <$> vectorOf 2 contByte + -- continuation bytes without a start byte + , listOf1 contByte + -- short 2-byte sequence + , (:[]) <$> choose (0xC2, 0xDF) + -- short 3-byte sequence + , (:) <$> choose (0xE0, 0xEF) <*> upTo 1 contByte + -- short 4-byte sequence + , (:) <$> choose (0xF0, 0xF4) <*> upTo 2 contByte + -- overlong encoding + , do k <- choose (0, 0xFFFF) + let c = chr k + case k of + _ | k < 0x80 -> oneof [ let (w, x) = ord2 c in pure [w, x] + , let (w, x, y) = ord3 c in pure [w, x, y] + , let (w, x, y, z) = ord4 c in pure [w, x, y, z] ] + | k < 0x7FF -> oneof [ let (w, x, y) = ord3 c in pure [w, x, y] + , let (w, x, y, z) = ord4 c in pure [w, x, y, z] ] + | otherwise -> oneof [ let (w, x, y, z) = ord4 c in pure [w, x, y, z] ] + ] + where + contByte :: Gen Word8 + contByte = (0x80 +) <$> choose (0, 0x3F) + upTo :: Int -> Gen a -> Gen [a] + upTo n gen = do + k <- choose (0, n) + vectorOf k gen + +genValidUtf8 :: Gen ByteString +genValidUtf8 = sized $ \size -> + if size <= 0 + then pure mempty + else oneof [ + B.append <$> genAscii <*> resize (size `div` 2) genValidUtf8, + B.append <$> gen2Byte <*> resize (size `div` 2) genValidUtf8, + B.append <$> gen3Byte <*> resize (size `div` 2) genValidUtf8, + B.append <$> gen4Byte <*> resize (size `div` 2) genValidUtf8, + B.replicate <$> resize (size * 16) arbitrary <*> elements [0x00 .. 0x7F] + ] + where + genAscii :: Gen ByteString + genAscii = B.pack . (:[]) <$> elements [0x00 .. 0x7F] + gen2Byte :: Gen ByteString + gen2Byte = do + b1 <- elements [0xC2 .. 0xDF] + b2 <- elements [0x80 .. 0xBF] + pure . B.pack $ [b1, b2] + gen3Byte :: Gen ByteString + gen3Byte = do + b1 <- elements [0xE0 .. 0xED] + b2 <- elements $ case b1 of + 0xE0 -> [0xA0 .. 0xBF] + 0xED -> [0x80 .. 0x9F] + _ -> [0x80 .. 0xBF] + b3 <- elements [0x80 .. 0xBF] + pure . B.pack $ [b1, b2, b3] + gen4Byte :: Gen ByteString + gen4Byte = do + b1 <- elements [0xF0 .. 0xF4] + b2 <- elements $ case b1 of + 0xF0 -> [0x90 .. 0xBF] + 0xF4 -> [0x80 .. 0x8F] + _ -> [0x80 .. 0xBF] + b3 <- elements [0x80 .. 0xBF] + b4 <- elements [0x80 .. 0xBF] + pure . B.pack $ [b1, b2, b3, b4] + +shrinkValidBS :: ByteString -> [ByteString] +shrinkValidBS bs = filter B.isValidUtf8 (map B.pack (shrink (B.unpack bs))) + +ord2 :: Char -> (Word8, Word8) +ord2 c = (x, y) + where + n :: Int + n = ord c + x :: Word8 + x = fromIntegral $ (n `shiftR` 6) + 0xC0 + y :: Word8 + y = fromIntegral $ (n .&. 0x3F) + 0x80 + +ord3 :: Char -> (Word8, Word8, Word8) +ord3 c = (x, y, z) + where + n :: Int + n = ord c + x :: Word8 + x = fromIntegral $ (n `shiftR` 12) + 0xE0 + y :: Word8 + y = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + z :: Word8 + z = fromIntegral $ (n .&. 0x3F) + 0x80 + +ord4 :: Char -> (Word8, Word8, Word8, Word8) +ord4 c = (x, y, z, a) + where + n :: Int + n = ord c + x :: Word8 + x = fromIntegral $ (n `shiftR` 18) + 0xF0 + y :: Word8 + y = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80 + z :: Word8 + z = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + a :: Word8 + a = fromIntegral $ (n .&. 0x3F) + 0x80 diff --git a/tests/LazyHClose.hs b/tests/LazyHClose.hs new file mode 100644 --- /dev/null +++ b/tests/LazyHClose.hs @@ -0,0 +1,64 @@ +module LazyHClose (testSuite) where + +import Control.Monad (void, forM_) +import Data.ByteString.Internal (toForeignPtr) +import Foreign.C.String (withCString) +import Foreign.ForeignPtr (finalizeForeignPtr) +import System.IO (openFile, openTempFile, hClose, hPutStrLn, IOMode(..)) +import System.Posix.Internals (c_unlink) +import Test.Tasty (TestTree, testGroup, withResource) +import Test.Tasty.QuickCheck (testProperty, ioProperty) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 + +n :: Int +n = 1000 + +testSuite :: TestTree +testSuite = withResource + (do (fn, h) <- openTempFile "." "lazy-hclose-test.tmp"; hPutStrLn h "x"; hClose h; pure fn) + removeFile $ \fn' -> + testGroup "LazyHClose" + [ testProperty "Testing resource leaks for Strict.readFile" $ ioProperty $ + forM_ [1..n] $ const $ do + fn <- fn' + r <- S.readFile fn + appendFile fn "" -- will fail, if fn has not been closed yet + + , testProperty "Testing resource leaks for Lazy.readFile" $ ioProperty $ + forM_ [1..n] $ const $ do + fn <- fn' + r <- L.readFile fn + L.length r `seq` return () + appendFile fn "" -- will fail, if fn has not been closed yet + + , testProperty "Testing resource leaks when converting lazy to strict" $ ioProperty $ + forM_ [1..n] $ const $ do + fn <- fn' + let release c = finalizeForeignPtr fp where (fp,_,_) = toForeignPtr c + r <- L.readFile fn + mapM_ release (L.toChunks r) + appendFile fn "" -- will fail, if fn has not been closed yet + + , testProperty "Testing strict hGetContents" $ ioProperty $ + forM_ [1..n] $ const $ do + fn <- fn' + h <- openFile fn ReadMode + r <- S.hGetContents h + S.last r `seq` return () + appendFile fn "" -- will fail, if fn has not been closed yet + + , testProperty "Testing lazy hGetContents" $ ioProperty $ + forM_ [1..n] $ const $ do + fn <- fn' + h <- openFile fn ReadMode + r <- L.hGetContents h + L.last r `seq` return () + appendFile fn "" -- will fail, if fn has not been closed yet + ] + +removeFile :: String -> IO () +removeFile fn = void $ withCString fn c_unlink diff --git a/tests/Lift.hs b/tests/Lift.hs new file mode 100644 --- /dev/null +++ b/tests/Lift.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE CPP #-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Lift (testSuite) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty, (===)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Short as SBS +import qualified Language.Haskell.TH.Syntax as TH + +testSuite :: TestTree +#ifdef wasm32_HOST_ARCH +testSuite = testGroup "Skipped, requires -fexternal-interpreter" [] +#else +testSuite = testGroup "Lift" + [ testGroup "strict" + [ testProperty "normal" $ + let bs = "foobar" :: BS.ByteString in + bs === $(TH.lift $ BS.pack [102,111,111,98,97,114]) + + , testProperty "binary" $ + let bs = "\0\1\2\3\0\1\2\3" :: BS.ByteString in + bs === $(TH.lift $ BS.pack [0,1,2,3,0,1,2,3]) + +#if MIN_VERSION_template_haskell(2,16,0) + , testProperty "typed" $ + let bs = "\0\1\2\3\0\1\2\3" :: BS.ByteString in + bs === $$(TH.liftTyped $ BS.pack [0,1,2,3,0,1,2,3]) +#endif + ] + + , testGroup "lazy" + [ testProperty "normal" $ + let bs = "foobar" :: LBS.ByteString in + bs === $(TH.lift $ LBS.pack [102,111,111,98,97,114]) + + , testProperty "binary" $ + let bs = "\0\1\2\3\0\1\2\3" :: LBS.ByteString in + bs === $(TH.lift $ LBS.pack [0,1,2,3,0,1,2,3]) + +#if MIN_VERSION_template_haskell(2,16,0) + , testProperty "typed" $ + let bs = "\0\1\2\3\0\1\2\3" :: LBS.ByteString in + bs === $$(TH.liftTyped $ LBS.pack [0,1,2,3,0,1,2,3]) +#endif + ] + + , testGroup "short" + [ testProperty "normal" $ + let bs = "foobar" :: SBS.ShortByteString in + bs === $(TH.lift $ SBS.pack [102,111,111,98,97,114]) + + , testProperty "binary" $ + let bs = "\0\1\2\3\0\1\2\3" :: SBS.ShortByteString in + bs === $(TH.lift $ SBS.pack [0,1,2,3,0,1,2,3]) + +#if MIN_VERSION_template_haskell(2,16,0) + , testProperty "typed" $ + let bs = "\0\1\2\3\0\1\2\3" :: SBS.ShortByteString in + bs === $$(TH.liftTyped $ SBS.pack [0,1,2,3,0,1,2,3]) +#endif + ] + ] +#endif diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,18 @@ +module Main (main) where + +import Test.Tasty + +import qualified Builder +import qualified IsValidUtf8 +import qualified LazyHClose +import qualified Lift +import qualified Properties + +main :: IO () +main = defaultMain $ testGroup "All" + [ Builder.testSuite + , IsValidUtf8.testSuite + , LazyHClose.testSuite + , Lift.testSuite + , Properties.testSuite + ] diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -1,2467 +1,750 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} --- --- Must have rules off, otherwise the fusion rules will replace the rhs --- with the lhs, and we only end up testing lhs == lhs --- - --- --- -fhpc interferes with rewrite rules firing. --- - -import Foreign.Storable -import Foreign.ForeignPtr -import Foreign.Marshal.Alloc -import Foreign.Marshal.Array -import GHC.Ptr -import Test.QuickCheck -import Control.Monad -import Control.Concurrent -import Control.Exception -import System.Directory - -import Data.List -import Data.Char -import Data.Word -import Data.Maybe -import Data.Int (Int64) -import Data.Monoid - -import Text.Printf -import Data.String - -import System.Environment -import System.IO -import System.IO.Unsafe - -import Data.ByteString.Lazy (ByteString(..), pack , unpack) -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Lazy.Internal (ByteString(..)) - -import qualified Data.ByteString as P -import qualified Data.ByteString.Internal as P -import qualified Data.ByteString.Unsafe as P -import qualified Data.ByteString.Char8 as C - -import qualified Data.ByteString.Lazy.Char8 as LC -import qualified Data.ByteString.Lazy.Char8 as D - -import qualified Data.ByteString.Lazy.Internal as L -import Prelude hiding (abs) - -import Rules -import QuickCheckUtils -import TestFramework - -toInt64 :: Int -> Int64 -toInt64 = fromIntegral - --- --- ByteString.Lazy.Char8 <=> ByteString.Char8 --- - -prop_concatCC = D.concat `eq1` C.concat -prop_nullCC = D.null `eq1` C.null -prop_reverseCC = D.reverse `eq1` C.reverse -prop_transposeCC = D.transpose `eq1` C.transpose -prop_groupCC = D.group `eq1` C.group -prop_groupByCC = D.groupBy `eq2` C.groupBy -prop_initsCC = D.inits `eq1` C.inits -prop_tailsCC = D.tails `eq1` C.tails -prop_allCC = D.all `eq2` C.all -prop_anyCC = D.any `eq2` C.any -prop_appendCC = D.append `eq2` C.append -prop_breakCC = D.break `eq2` C.break -prop_concatMapCC = adjustSize (min 50) $ - D.concatMap `eq2` C.concatMap -prop_consCC = D.cons `eq2` C.cons -prop_consCC' = D.cons' `eq2` C.cons -prop_unconsCC = D.uncons `eq1` C.uncons -prop_countCC = D.count `eq2` ((toInt64 .) . C.count) -prop_dropCC = (D.drop . toInt64) `eq2` C.drop -prop_dropWhileCC = D.dropWhile `eq2` C.dropWhile -prop_filterCC = D.filter `eq2` C.filter -prop_findCC = D.find `eq2` C.find -prop_findIndexCC = D.findIndex `eq2` ((fmap toInt64 .) . C.findIndex) -prop_findIndicesCC = D.findIndices `eq2` ((fmap toInt64 .) . C.findIndices) -prop_isPrefixOfCC = D.isPrefixOf `eq2` C.isPrefixOf -prop_mapCC = D.map `eq2` C.map -prop_replicateCC = forAll arbitrarySizedIntegral $ - (D.replicate . toInt64) `eq2` C.replicate -prop_snocCC = D.snoc `eq2` C.snoc -prop_spanCC = D.span `eq2` C.span -prop_splitCC = D.split `eq2` C.split -prop_splitAtCC = (D.splitAt . toInt64) `eq2` C.splitAt -prop_takeCC = (D.take . toInt64) `eq2` C.take -prop_takeWhileCC = D.takeWhile `eq2` C.takeWhile -prop_elemCC = D.elem `eq2` C.elem -prop_notElemCC = D.notElem `eq2` C.notElem -prop_elemIndexCC = D.elemIndex `eq2` ((fmap toInt64 .) . C.elemIndex) -prop_elemIndicesCC = D.elemIndices `eq2` ((fmap toInt64 .) . C.elemIndices) -prop_lengthCC = D.length `eq1` (toInt64 . C.length) - -prop_headCC = D.head `eqnotnull1` C.head -prop_initCC = D.init `eqnotnull1` C.init -prop_lastCC = D.last `eqnotnull1` C.last -prop_maximumCC = D.maximum `eqnotnull1` C.maximum -prop_minimumCC = D.minimum `eqnotnull1` C.minimum -prop_tailCC = D.tail `eqnotnull1` C.tail -prop_foldl1CC = D.foldl1 `eqnotnull2` C.foldl1 -prop_foldl1CC' = D.foldl1' `eqnotnull2` C.foldl1' -prop_foldr1CC = D.foldr1 `eqnotnull2` C.foldr1 -prop_foldr1CC' = D.foldr1 `eqnotnull2` C.foldr1' -prop_scanlCC = D.scanl `eqnotnull3` C.scanl - -prop_intersperseCC = D.intersperse `eq2` C.intersperse - -prop_foldlCC = eq3 - (D.foldl :: (X -> Char -> X) -> X -> B -> X) - (C.foldl :: (X -> Char -> X) -> X -> P -> X) -prop_foldlCC' = eq3 - (D.foldl' :: (X -> Char -> X) -> X -> B -> X) - (C.foldl' :: (X -> Char -> X) -> X -> P -> X) -prop_foldrCC = eq3 - (D.foldr :: (Char -> X -> X) -> X -> B -> X) - (C.foldr :: (Char -> X -> X) -> X -> P -> X) -prop_foldrCC' = eq3 - (D.foldr :: (Char -> X -> X) -> X -> B -> X) - (C.foldr' :: (Char -> X -> X) -> X -> P -> X) -prop_mapAccumLCC = eq3 - (D.mapAccumL :: (X -> Char -> (X,Char)) -> X -> B -> (X, B)) - (C.mapAccumL :: (X -> Char -> (X,Char)) -> X -> P -> (X, P)) - ---prop_mapIndexedCC = D.mapIndexed `eq2` C.mapIndexed ---prop_mapIndexedPL = L.mapIndexed `eq2` P.mapIndexed - ---prop_mapAccumL_mapIndexedBP = --- P.mapIndexed `eq2` --- (\k p -> snd $ P.mapAccumL (\i w -> (i+1, k i w)) (0::Int) p) - --- --- ByteString.Lazy <=> ByteString --- - -prop_concatBP = adjustSize (`div` 2) $ - L.concat `eq1` P.concat -prop_nullBP = L.null `eq1` P.null -prop_reverseBP = L.reverse `eq1` P.reverse - -prop_transposeBP = L.transpose `eq1` P.transpose -prop_groupBP = L.group `eq1` P.group -prop_groupByBP = L.groupBy `eq2` P.groupBy -prop_initsBP = L.inits `eq1` P.inits -prop_tailsBP = L.tails `eq1` P.tails -prop_allBP = L.all `eq2` P.all -prop_anyBP = L.any `eq2` P.any -prop_appendBP = L.append `eq2` P.append -prop_breakBP = L.break `eq2` P.break -prop_concatMapBP = adjustSize (`div` 4) $ - L.concatMap `eq2` P.concatMap -prop_consBP = L.cons `eq2` P.cons -prop_consBP' = L.cons' `eq2` P.cons -prop_unconsBP = L.uncons `eq1` P.uncons -prop_countBP = L.count `eq2` ((toInt64 .) . P.count) -prop_dropBP = (L.drop. toInt64) `eq2` P.drop -prop_dropWhileBP = L.dropWhile `eq2` P.dropWhile -prop_filterBP = L.filter `eq2` P.filter -prop_findBP = L.find `eq2` P.find -prop_findIndexBP = L.findIndex `eq2` ((fmap toInt64 .) . P.findIndex) -prop_findIndicesBP = L.findIndices `eq2` ((fmap toInt64 .) . P.findIndices) -prop_isPrefixOfBP = L.isPrefixOf `eq2` P.isPrefixOf -prop_mapBP = L.map `eq2` P.map -prop_replicateBP = forAll arbitrarySizedIntegral $ - (L.replicate. toInt64) `eq2` P.replicate -prop_snocBP = L.snoc `eq2` P.snoc -prop_spanBP = L.span `eq2` P.span -prop_splitBP = L.split `eq2` P.split -prop_splitAtBP = (L.splitAt. toInt64) `eq2` P.splitAt -prop_takeBP = (L.take . toInt64) `eq2` P.take -prop_takeWhileBP = L.takeWhile `eq2` P.takeWhile -prop_elemBP = L.elem `eq2` P.elem -prop_notElemBP = L.notElem `eq2` P.notElem -prop_elemIndexBP = L.elemIndex `eq2` ((fmap toInt64 .) . P.elemIndex) -prop_elemIndicesBP = L.elemIndices `eq2` ((fmap toInt64 .) . P.elemIndices) -prop_intersperseBP = L.intersperse `eq2` P.intersperse -prop_lengthBP = L.length `eq1` (toInt64 . P.length) -prop_readIntBP = D.readInt `eq1` C.readInt -prop_linesBP = D.lines `eq1` C.lines - --- double check: --- Currently there's a bug in the lazy bytestring version of lines, this --- catches it: -prop_linesNLBP = eq1 D.lines C.lines x - where x = D.pack "one\ntwo\n\n\nfive\n\nseven\n" - -prop_headBP = L.head `eqnotnull1` P.head -prop_initBP = L.init `eqnotnull1` P.init -prop_lastBP = L.last `eqnotnull1` P.last -prop_maximumBP = L.maximum `eqnotnull1` P.maximum -prop_minimumBP = L.minimum `eqnotnull1` P.minimum -prop_tailBP = L.tail `eqnotnull1` P.tail -prop_foldl1BP = L.foldl1 `eqnotnull2` P.foldl1 -prop_foldl1BP' = L.foldl1' `eqnotnull2` P.foldl1' -prop_foldr1BP = L.foldr1 `eqnotnull2` P.foldr1 -prop_foldr1BP' = L.foldr1 `eqnotnull2` P.foldr1' -prop_scanlBP = L.scanl `eqnotnull3` P.scanl - - -prop_eqBP = eq2 - ((==) :: B -> B -> Bool) - ((==) :: P -> P -> Bool) -prop_compareBP = eq2 - ((compare) :: B -> B -> Ordering) - ((compare) :: P -> P -> Ordering) -prop_foldlBP = eq3 - (L.foldl :: (X -> W -> X) -> X -> B -> X) - (P.foldl :: (X -> W -> X) -> X -> P -> X) -prop_foldlBP' = eq3 - (L.foldl' :: (X -> W -> X) -> X -> B -> X) - (P.foldl' :: (X -> W -> X) -> X -> P -> X) -prop_foldrBP = eq3 - (L.foldr :: (W -> X -> X) -> X -> B -> X) - (P.foldr :: (W -> X -> X) -> X -> P -> X) -prop_foldrBP' = eq3 - (L.foldr :: (W -> X -> X) -> X -> B -> X) - (P.foldr' :: (W -> X -> X) -> X -> P -> X) -prop_mapAccumLBP = eq3 - (L.mapAccumL :: (X -> W -> (X,W)) -> X -> B -> (X, B)) - (P.mapAccumL :: (X -> W -> (X,W)) -> X -> P -> (X, P)) - -prop_unfoldrBP = - forAll arbitrarySizedIntegral $ - eq3 - ((\n f a -> L.take (fromIntegral n) $ - L.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> B) - ((\n f a -> fst $ - P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P) - -prop_unfoldr2BP = - forAll arbitrarySizedIntegral $ \n -> - forAll arbitrarySizedIntegral $ \a -> - eq2 - ((\n a -> P.take (n*100) $ - P.unfoldr (\x -> if x <= (n*100) then Just (fromIntegral x, x + 1) else Nothing) a) - :: Int -> Int -> P) - ((\n a -> fst $ - P.unfoldrN (n*100) (\x -> if x <= (n*100) then Just (fromIntegral x, x + 1) else Nothing) a) - :: Int -> Int -> P) - n a - -prop_unfoldr2CP = - forAll arbitrarySizedIntegral $ \n -> - forAll arbitrarySizedIntegral $ \a -> - eq2 - ((\n a -> C.take (n*100) $ - C.unfoldr (\x -> if x <= (n*100) then Just (chr (x `mod` 256), x + 1) else Nothing) a) - :: Int -> Int -> P) - ((\n a -> fst $ - C.unfoldrN (n*100) (\x -> if x <= (n*100) then Just (chr (x `mod` 256), x + 1) else Nothing) a) - :: Int -> Int -> P) - n a - - -prop_unfoldrLC = - forAll arbitrarySizedIntegral $ - eq3 - ((\n f a -> LC.take (fromIntegral n) $ - LC.unfoldr f a) :: Int -> (X -> Maybe (Char,X)) -> X -> B) - ((\n f a -> fst $ - C.unfoldrN n f a) :: Int -> (X -> Maybe (Char,X)) -> X -> P) - -prop_cycleLC a = - not (LC.null a) ==> - forAll arbitrarySizedIntegral $ - eq1 - ((\n -> LC.take (fromIntegral n) $ - LC.cycle a - ) :: Int -> B) - - ((\n -> LC.take (fromIntegral (n::Int)) . LC.concat $ - unfoldr (\x -> Just (x,x) ) a - ) :: Int -> B) - - -prop_iterateLC = - forAll arbitrarySizedIntegral $ - eq3 - ((\n f a -> LC.take (fromIntegral n) $ - LC.iterate f a) :: Int -> (Char -> Char) -> Char -> B) - ((\n f a -> fst $ - C.unfoldrN n (\a -> Just (f a, f a)) a) :: Int -> (Char -> Char) -> Char -> P) - -prop_iterateLC_2 = - forAll arbitrarySizedIntegral $ - eq3 - ((\n f a -> LC.take (fromIntegral n) $ - LC.iterate f a) :: Int -> (Char -> Char) -> Char -> B) - ((\n f a -> LC.take (fromIntegral n) $ - LC.unfoldr (\a -> Just (f a, f a)) a) :: Int -> (Char -> Char) -> Char -> B) - -prop_iterateL = - forAll arbitrarySizedIntegral $ - eq3 - ((\n f a -> L.take (fromIntegral n) $ - L.iterate f a) :: Int -> (W -> W) -> W -> B) - ((\n f a -> fst $ - P.unfoldrN n (\a -> Just (f a, f a)) a) :: Int -> (W -> W) -> W -> P) - -prop_repeatLC = - forAll arbitrarySizedIntegral $ - eq2 - ((\n a -> LC.take (fromIntegral n) $ - LC.repeat a) :: Int -> Char -> B) - ((\n a -> fst $ - C.unfoldrN n (\a -> Just (a, a)) a) :: Int -> Char -> P) - -prop_repeatL = - forAll arbitrarySizedIntegral $ - eq2 - ((\n a -> L.take (fromIntegral n) $ - L.repeat a) :: Int -> W -> B) - ((\n a -> fst $ - P.unfoldrN n (\a -> Just (a, a)) a) :: Int -> W -> P) - --- --- properties comparing ByteString.Lazy `eq1` List --- - -prop_concatBL = adjustSize (`div` 2) $ - L.concat `eq1` (concat :: [[W]] -> [W]) -prop_lengthBL = L.length `eq1` (toInt64 . length :: [W] -> Int64) -prop_nullBL = L.null `eq1` (null :: [W] -> Bool) -prop_reverseBL = L.reverse `eq1` (reverse :: [W] -> [W]) -prop_transposeBL = L.transpose `eq1` (transpose :: [[W]] -> [[W]]) -prop_groupBL = L.group `eq1` (group :: [W] -> [[W]]) -prop_groupByBL = L.groupBy `eq2` (groupBy :: (W -> W -> Bool) -> [W] -> [[W]]) -prop_initsBL = L.inits `eq1` (inits :: [W] -> [[W]]) -prop_tailsBL = L.tails `eq1` (tails :: [W] -> [[W]]) -prop_allBL = L.all `eq2` (all :: (W -> Bool) -> [W] -> Bool) -prop_anyBL = L.any `eq2` (any :: (W -> Bool) -> [W] -> Bool) -prop_appendBL = L.append `eq2` ((++) :: [W] -> [W] -> [W]) -prop_breakBL = L.break `eq2` (break :: (W -> Bool) -> [W] -> ([W],[W])) -prop_concatMapBL = adjustSize (`div` 2) $ - L.concatMap `eq2` (concatMap :: (W -> [W]) -> [W] -> [W]) -prop_consBL = L.cons `eq2` ((:) :: W -> [W] -> [W]) -prop_dropBL = (L.drop . toInt64) `eq2` (drop :: Int -> [W] -> [W]) -prop_dropWhileBL = L.dropWhile `eq2` (dropWhile :: (W -> Bool) -> [W] -> [W]) -prop_filterBL = L.filter `eq2` (filter :: (W -> Bool ) -> [W] -> [W]) -prop_findBL = L.find `eq2` (find :: (W -> Bool) -> [W] -> Maybe W) -prop_findIndicesBL = L.findIndices `eq2` ((fmap toInt64 .) . findIndices:: (W -> Bool) -> [W] -> [Int64]) -prop_findIndexBL = L.findIndex `eq2` ((fmap toInt64 .) . findIndex :: (W -> Bool) -> [W] -> Maybe Int64) -prop_isPrefixOfBL = L.isPrefixOf `eq2` (isPrefixOf:: [W] -> [W] -> Bool) -prop_mapBL = L.map `eq2` (map :: (W -> W) -> [W] -> [W]) -prop_replicateBL = forAll arbitrarySizedIntegral $ - (L.replicate . toInt64) `eq2` (replicate :: Int -> W -> [W]) -prop_snocBL = L.snoc `eq2` ((\xs x -> xs ++ [x]) :: [W] -> W -> [W]) -prop_spanBL = L.span `eq2` (span :: (W -> Bool) -> [W] -> ([W],[W])) -prop_splitAtBL = (L.splitAt . toInt64) `eq2` (splitAt :: Int -> [W] -> ([W],[W])) -prop_takeBL = (L.take . toInt64) `eq2` (take :: Int -> [W] -> [W]) -prop_takeWhileBL = L.takeWhile `eq2` (takeWhile :: (W -> Bool) -> [W] -> [W]) -prop_elemBL = L.elem `eq2` (elem :: W -> [W] -> Bool) -prop_notElemBL = L.notElem `eq2` (notElem :: W -> [W] -> Bool) -prop_elemIndexBL = L.elemIndex `eq2` ((fmap toInt64 .) . elemIndex :: W -> [W] -> Maybe Int64) -prop_elemIndicesBL = L.elemIndices `eq2` ((fmap toInt64 .) . elemIndices :: W -> [W] -> [Int64]) -prop_linesBL = D.lines `eq1` (lines :: String -> [String]) - -prop_foldl1BL = L.foldl1 `eqnotnull2` (foldl1 :: (W -> W -> W) -> [W] -> W) -prop_foldl1BL' = L.foldl1' `eqnotnull2` (foldl1' :: (W -> W -> W) -> [W] -> W) -prop_foldr1BL = L.foldr1 `eqnotnull2` (foldr1 :: (W -> W -> W) -> [W] -> W) -prop_headBL = L.head `eqnotnull1` (head :: [W] -> W) -prop_initBL = L.init `eqnotnull1` (init :: [W] -> [W]) -prop_lastBL = L.last `eqnotnull1` (last :: [W] -> W) -prop_maximumBL = L.maximum `eqnotnull1` (maximum :: [W] -> W) -prop_minimumBL = L.minimum `eqnotnull1` (minimum :: [W] -> W) -prop_tailBL = L.tail `eqnotnull1` (tail :: [W] -> [W]) - -prop_eqBL = eq2 - ((==) :: B -> B -> Bool) - ((==) :: [W] -> [W] -> Bool) -prop_compareBL = eq2 - ((compare) :: B -> B -> Ordering) - ((compare) :: [W] -> [W] -> Ordering) -prop_foldlBL = eq3 - (L.foldl :: (X -> W -> X) -> X -> B -> X) - ( foldl :: (X -> W -> X) -> X -> [W] -> X) -prop_foldlBL' = eq3 - (L.foldl' :: (X -> W -> X) -> X -> B -> X) - ( foldl' :: (X -> W -> X) -> X -> [W] -> X) -prop_foldrBL = eq3 - (L.foldr :: (W -> X -> X) -> X -> B -> X) - ( foldr :: (W -> X -> X) -> X -> [W] -> X) -prop_mapAccumLBL = eq3 - (L.mapAccumL :: (X -> W -> (X,W)) -> X -> B -> (X, B)) - ( mapAccumL :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) - -prop_mapAccumRBL = eq3 - (L.mapAccumR :: (X -> W -> (X,W)) -> X -> B -> (X, B)) - ( mapAccumR :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) - -prop_mapAccumRDL = eq3 - (D.mapAccumR :: (X -> Char -> (X,Char)) -> X -> B -> (X, B)) - ( mapAccumR :: (X -> Char -> (X,Char)) -> X -> [Char] -> (X, [Char])) - -prop_mapAccumRCC = eq3 - (C.mapAccumR :: (X -> Char -> (X,Char)) -> X -> P -> (X, P)) - ( mapAccumR :: (X -> Char -> (X,Char)) -> X -> [Char] -> (X, [Char])) - -prop_unfoldrBL = - forAll arbitrarySizedIntegral $ - eq3 - ((\n f a -> L.take (fromIntegral n) $ - L.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> B) - ((\n f a -> take n $ - unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> [W]) - --- --- And finally, check correspondance between Data.ByteString and List --- - -prop_lengthPL = (fromIntegral.P.length :: P -> Int) `eq1` (length :: [W] -> Int) -prop_nullPL = P.null `eq1` (null :: [W] -> Bool) -prop_reversePL = P.reverse `eq1` (reverse :: [W] -> [W]) -prop_transposePL = P.transpose `eq1` (transpose :: [[W]] -> [[W]]) -prop_groupPL = P.group `eq1` (group :: [W] -> [[W]]) -prop_groupByPL = P.groupBy `eq2` (groupBy :: (W -> W -> Bool) -> [W] -> [[W]]) -prop_initsPL = P.inits `eq1` (inits :: [W] -> [[W]]) -prop_tailsPL = P.tails `eq1` (tails :: [W] -> [[W]]) -prop_concatPL = adjustSize (`div` 2) $ - P.concat `eq1` (concat :: [[W]] -> [W]) -prop_allPL = P.all `eq2` (all :: (W -> Bool) -> [W] -> Bool) -prop_anyPL = P.any `eq2` (any :: (W -> Bool) -> [W] -> Bool) -prop_appendPL = P.append `eq2` ((++) :: [W] -> [W] -> [W]) -prop_breakPL = P.break `eq2` (break :: (W -> Bool) -> [W] -> ([W],[W])) -prop_concatMapPL = adjustSize (`div` 2) $ - P.concatMap `eq2` (concatMap :: (W -> [W]) -> [W] -> [W]) -prop_consPL = P.cons `eq2` ((:) :: W -> [W] -> [W]) -prop_dropPL = P.drop `eq2` (drop :: Int -> [W] -> [W]) -prop_dropWhilePL = P.dropWhile `eq2` (dropWhile :: (W -> Bool) -> [W] -> [W]) -prop_filterPL = P.filter `eq2` (filter :: (W -> Bool ) -> [W] -> [W]) -prop_filterPL_rule= (\x -> P.filter ((==) x)) `eq2` -- test rules - ((\x -> filter ((==) x)) :: W -> [W] -> [W]) - --- under lambda doesn't fire? -prop_filterLC_rule= (f) `eq2` -- test rules - ((\x -> filter ((==) x)) :: Char -> [Char] -> [Char]) - where - f x s = LC.filter ((==) x) s - -prop_partitionPL = P.partition `eq2` (partition :: (W -> Bool ) -> [W] -> ([W],[W])) -prop_partitionLL = L.partition `eq2` (partition :: (W -> Bool ) -> [W] -> ([W],[W])) -prop_findPL = P.find `eq2` (find :: (W -> Bool) -> [W] -> Maybe W) -prop_findIndexPL = P.findIndex `eq2` (findIndex :: (W -> Bool) -> [W] -> Maybe Int) -prop_isPrefixOfPL = P.isPrefixOf`eq2` (isPrefixOf:: [W] -> [W] -> Bool) -prop_isInfixOfPL = P.isInfixOf `eq2` (isInfixOf:: [W] -> [W] -> Bool) -prop_mapPL = P.map `eq2` (map :: (W -> W) -> [W] -> [W]) -prop_replicatePL = forAll arbitrarySizedIntegral $ - P.replicate `eq2` (replicate :: Int -> W -> [W]) -prop_snocPL = P.snoc `eq2` ((\xs x -> xs ++ [x]) :: [W] -> W -> [W]) -prop_spanPL = P.span `eq2` (span :: (W -> Bool) -> [W] -> ([W],[W])) -prop_splitAtPL = P.splitAt `eq2` (splitAt :: Int -> [W] -> ([W],[W])) -prop_takePL = P.take `eq2` (take :: Int -> [W] -> [W]) -prop_takeWhilePL = P.takeWhile `eq2` (takeWhile :: (W -> Bool) -> [W] -> [W]) -prop_elemPL = P.elem `eq2` (elem :: W -> [W] -> Bool) -prop_notElemPL = P.notElem `eq2` (notElem :: W -> [W] -> Bool) -prop_elemIndexPL = P.elemIndex `eq2` (elemIndex :: W -> [W] -> Maybe Int) -prop_linesPL = C.lines `eq1` (lines :: String -> [String]) -prop_findIndicesPL= P.findIndices`eq2` (findIndices:: (W -> Bool) -> [W] -> [Int]) -prop_elemIndicesPL= P.elemIndices`eq2` (elemIndices:: W -> [W] -> [Int]) -prop_zipPL = P.zip `eq2` (zip :: [W] -> [W] -> [(W,W)]) -prop_zipCL = C.zip `eq2` (zip :: [Char] -> [Char] -> [(Char,Char)]) -prop_zipLL = L.zip `eq2` (zip :: [W] -> [W] -> [(W,W)]) -prop_unzipPL = P.unzip `eq1` (unzip :: [(W,W)] -> ([W],[W])) -prop_unzipLL = L.unzip `eq1` (unzip :: [(W,W)] -> ([W],[W])) -prop_unzipCL = C.unzip `eq1` (unzip :: [(Char,Char)] -> ([Char],[Char])) - -prop_foldl1PL = P.foldl1 `eqnotnull2` (foldl1 :: (W -> W -> W) -> [W] -> W) -prop_foldl1PL' = P.foldl1' `eqnotnull2` (foldl1' :: (W -> W -> W) -> [W] -> W) -prop_foldr1PL = P.foldr1 `eqnotnull2` (foldr1 :: (W -> W -> W) -> [W] -> W) -prop_scanlPL = P.scanl `eqnotnull3` (scanl :: (W -> W -> W) -> W -> [W] -> [W]) -prop_scanl1PL = P.scanl1 `eqnotnull2` (scanl1 :: (W -> W -> W) -> [W] -> [W]) -prop_scanrPL = P.scanr `eqnotnull3` (scanr :: (W -> W -> W) -> W -> [W] -> [W]) -prop_scanr1PL = P.scanr1 `eqnotnull2` (scanr1 :: (W -> W -> W) -> [W] -> [W]) -prop_headPL = P.head `eqnotnull1` (head :: [W] -> W) -prop_initPL = P.init `eqnotnull1` (init :: [W] -> [W]) -prop_lastPL = P.last `eqnotnull1` (last :: [W] -> W) -prop_maximumPL = P.maximum `eqnotnull1` (maximum :: [W] -> W) -prop_minimumPL = P.minimum `eqnotnull1` (minimum :: [W] -> W) -prop_tailPL = P.tail `eqnotnull1` (tail :: [W] -> [W]) - -prop_scanl1CL = C.scanl1 `eqnotnull2` (scanl1 :: (Char -> Char -> Char) -> [Char] -> [Char]) -prop_scanrCL = C.scanr `eqnotnull3` (scanr :: (Char -> Char -> Char) -> Char -> [Char] -> [Char]) -prop_scanr1CL = C.scanr1 `eqnotnull2` (scanr1 :: (Char -> Char -> Char) -> [Char] -> [Char]) - --- prop_zipWithPL' = P.zipWith' `eq3` (zipWith :: (W -> W -> W) -> [W] -> [W] -> [W]) - -prop_zipWithPL = (P.zipWith :: (W -> W -> X) -> P -> P -> [X]) `eq3` - (zipWith :: (W -> W -> X) -> [W] -> [W] -> [X]) - -prop_zipWithPL_rules = (P.zipWith :: (W -> W -> W) -> P -> P -> [W]) `eq3` - (zipWith :: (W -> W -> W) -> [W] -> [W] -> [W]) - -prop_eqPL = eq2 - ((==) :: P -> P -> Bool) - ((==) :: [W] -> [W] -> Bool) -prop_comparePL = eq2 - ((compare) :: P -> P -> Ordering) - ((compare) :: [W] -> [W] -> Ordering) -prop_foldlPL = eq3 - (P.foldl :: (X -> W -> X) -> X -> P -> X) - ( foldl :: (X -> W -> X) -> X -> [W] -> X) -prop_foldlPL' = eq3 - (P.foldl' :: (X -> W -> X) -> X -> P -> X) - ( foldl' :: (X -> W -> X) -> X -> [W] -> X) -prop_foldrPL = eq3 - (P.foldr :: (W -> X -> X) -> X -> P -> X) - ( foldr :: (W -> X -> X) -> X -> [W] -> X) -prop_mapAccumLPL= eq3 - (P.mapAccumL :: (X -> W -> (X,W)) -> X -> P -> (X, P)) - ( mapAccumL :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) -prop_mapAccumRPL= eq3 - (P.mapAccumR :: (X -> W -> (X,W)) -> X -> P -> (X, P)) - ( mapAccumR :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) -prop_unfoldrPL = - forAll arbitrarySizedIntegral $ - eq3 - ((\n f a -> fst $ - P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P) - ((\n f a -> take n $ - unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> [W]) - ------------------------------------------------------------------------- --- --- These are miscellaneous tests left over. Or else they test some --- property internal to a type (i.e. head . sort == minimum), without --- reference to a model type. --- - -invariant :: L.ByteString -> Bool -invariant Empty = True -invariant (Chunk c cs) = not (P.null c) && invariant cs - -prop_invariant = invariant - -prop_eq_refl x = x == (x :: ByteString) -prop_eq_symm x y = (x == y) == (y == (x :: ByteString)) - -prop_eq1 xs = xs == (unpack . pack $ xs) -prop_eq2 xs = xs == (xs :: ByteString) -prop_eq3 xs ys = (xs == ys) == (unpack xs == unpack ys) - -prop_compare1 xs = (pack xs `compare` pack xs) == EQ -prop_compare2 xs c = (pack (xs++[c]) `compare` pack xs) == GT -prop_compare3 xs c = (pack xs `compare` pack (xs++[c])) == LT - -prop_compare4 xs = (not (null xs)) ==> (pack xs `compare` L.empty) == GT -prop_compare5 xs = (not (null xs)) ==> (L.empty `compare` pack xs) == LT -prop_compare6 xs ys = (not (null ys)) ==> (pack (xs++ys) `compare` pack xs) == GT - -prop_compare7 x y = x `compare` y == (L.singleton x `compare` L.singleton y) -prop_compare8 xs ys = xs `compare` ys == (L.pack xs `compare` L.pack ys) - -prop_compare7LL x y = x `compare` y == (LC.singleton x `compare` LC.singleton y) - -prop_empty1 = L.length L.empty == 0 -prop_empty2 = L.unpack L.empty == [] - -prop_packunpack s = (L.unpack . L.pack) s == id s -prop_unpackpack s = (L.pack . L.unpack) s == id s - -prop_null xs = null (L.unpack xs) == L.null xs - -prop_length1 xs = fromIntegral (length xs) == L.length (L.pack xs) - -prop_length2 xs = L.length xs == length1 xs - where length1 ys - | L.null ys = 0 - | otherwise = 1 + length1 (L.tail ys) - -prop_cons1 c xs = unpack (L.cons c (pack xs)) == (c:xs) -prop_cons2 c = L.singleton c == (c `L.cons` L.empty) -prop_cons3 c = unpack (L.singleton c) == (c:[]) -prop_cons4 c = (c `L.cons` L.empty) == pack (c:[]) - -prop_snoc1 xs c = xs ++ [c] == unpack ((pack xs) `L.snoc` c) - -prop_head xs = (not (null xs)) ==> head xs == (L.head . pack) xs -prop_head1 xs = not (L.null xs) ==> L.head xs == head (L.unpack xs) - -prop_tail xs = not (L.null xs) ==> L.tail xs == pack (tail (unpack xs)) -prop_tail1 xs = (not (null xs)) ==> tail xs == (unpack . L.tail . pack) xs - -prop_last xs = (not (null xs)) ==> last xs == (L.last . pack) xs - -prop_init xs = - (not (null xs)) ==> - init xs == (unpack . L.init . pack) xs - -prop_append1 xs = (xs ++ xs) == (unpack $ pack xs `L.append` pack xs) -prop_append2 xs ys = (xs ++ ys) == (unpack $ pack xs `L.append` pack ys) -prop_append3 xs ys = L.append xs ys == pack (unpack xs ++ unpack ys) - -prop_map1 f xs = L.map f (pack xs) == pack (map f xs) -prop_map2 f g xs = L.map f (L.map g xs) == L.map (f . g) xs -prop_map3 f xs = map f xs == (unpack . L.map f . pack) xs - -prop_filter1 c xs = (filter (/=c) xs) == (unpack $ L.filter (/=c) (pack xs)) -prop_filter2 p xs = (filter p xs) == (unpack $ L.filter p (pack xs)) - -prop_reverse xs = reverse xs == (unpack . L.reverse . pack) xs -prop_reverse1 xs = L.reverse (pack xs) == pack (reverse xs) -prop_reverse2 xs = reverse (unpack xs) == (unpack . L.reverse) xs - -prop_transpose xs = (transpose xs) == ((map unpack) . L.transpose . (map pack)) xs - -prop_foldl f c xs = L.foldl f c (pack xs) == foldl f c xs - where _ = c :: Char - -prop_foldr f c xs = L.foldl f c (pack xs) == foldl f c xs - where _ = c :: Char - -prop_foldl_1 xs = L.foldl (\xs c -> c `L.cons` xs) L.empty xs == L.reverse xs -prop_foldr_1 xs = L.foldr (\c xs -> c `L.cons` xs) L.empty xs == id xs - -prop_foldl1_1 xs = - (not . L.null) xs ==> - L.foldl1 (\x c -> if c > x then c else x) xs == - L.foldl (\x c -> if c > x then c else x) 0 xs - -prop_foldl1_2 xs = - (not . L.null) xs ==> - L.foldl1 const xs == L.head xs - -prop_foldl1_3 xs = - (not . L.null) xs ==> - L.foldl1 (flip const) xs == L.last xs - -prop_foldr1_1 xs = - (not . L.null) xs ==> - L.foldr1 (\c x -> if c > x then c else x) xs == - L.foldr (\c x -> if c > x then c else x) 0 xs - -prop_foldr1_2 xs = - (not . L.null) xs ==> - L.foldr1 (flip const) xs == L.last xs - -prop_foldr1_3 xs = - (not . L.null) xs ==> - L.foldr1 const xs == L.head xs - -prop_concat1 xs = (concat [xs,xs]) == (unpack $ L.concat [pack xs, pack xs]) -prop_concat2 xs = (concat [xs,[]]) == (unpack $ L.concat [pack xs, pack []]) -prop_concat3 xss = adjustSize (`div` 2) $ - L.concat (map pack xss) == pack (concat xss) - -prop_concatMap xs = L.concatMap L.singleton xs == (pack . concatMap (:[]) . unpack) xs - -prop_any xs a = (any (== a) xs) == (L.any (== a) (pack xs)) -prop_all xs a = (all (== a) xs) == (L.all (== a) (pack xs)) - -prop_maximum xs = (not (null xs)) ==> (maximum xs) == (L.maximum ( pack xs )) -prop_minimum xs = (not (null xs)) ==> (minimum xs) == (L.minimum ( pack xs )) - -prop_replicate1 c = - forAll arbitrarySizedIntegral $ \(Positive n) -> - unpack (L.replicate (fromIntegral n) c) == replicate n c - -prop_replicate2 c = unpack (L.replicate 0 c) == replicate 0 c - -prop_take1 i xs = L.take (fromIntegral i) (pack xs) == pack (take i xs) -prop_drop1 i xs = L.drop (fromIntegral i) (pack xs) == pack (drop i xs) - -prop_splitAt i xs = --collect (i >= 0 && i < length xs) $ - L.splitAt (fromIntegral i) (pack xs) == let (a,b) = splitAt i xs in (pack a, pack b) - -prop_takeWhile f xs = L.takeWhile f (pack xs) == pack (takeWhile f xs) -prop_dropWhile f xs = L.dropWhile f (pack xs) == pack (dropWhile f xs) - -prop_break f xs = L.break f (pack xs) == - let (a,b) = break f xs in (pack a, pack b) - -prop_breakspan xs c = L.break (==c) xs == L.span (/=c) xs - -prop_span xs a = (span (/=a) xs) == (let (x,y) = L.span (/=a) (pack xs) in (unpack x, unpack y)) - --- prop_breakByte xs c = L.break (== c) xs == L.breakByte c xs - --- prop_spanByte c xs = (L.span (==c) xs) == L.spanByte c xs - -prop_split c xs = (map L.unpack . map checkInvariant . L.split c $ xs) - == (map P.unpack . P.split c . P.pack . L.unpack $ xs) - -prop_splitWith f xs = (l1 == l2 || l1 == l2+1) && - sum (map L.length splits) == L.length xs - l2 - where splits = L.splitWith f xs - l1 = fromIntegral (length splits) - l2 = L.length (L.filter f xs) - -prop_splitWith_D f xs = (l1 == l2 || l1 == l2+1) && - sum (map D.length splits) == D.length xs - l2 - where splits = D.splitWith f xs - l1 = fromIntegral (length splits) - l2 = D.length (D.filter f xs) - -prop_splitWith_C f xs = (l1 == l2 || l1 == l2+1) && - sum (map C.length splits) == C.length xs - l2 - where splits = C.splitWith f xs - l1 = fromIntegral (length splits) - l2 = C.length (C.filter f xs) - -prop_joinsplit c xs = L.intercalate (pack [c]) (L.split c xs) == id xs - -prop_group xs = group xs == (map unpack . L.group . pack) xs -prop_groupBy f xs = groupBy f xs == (map unpack . L.groupBy f . pack) xs -prop_groupBy_LC f xs = groupBy f xs == (map LC.unpack . LC.groupBy f . LC.pack) xs - --- prop_joinjoinByte xs ys c = L.joinWithByte c xs ys == L.join (L.singleton c) [xs,ys] - -prop_index xs = - not (null xs) ==> - forAll indices $ \i -> (xs !! i) == L.pack xs `L.index` (fromIntegral i) - where indices = choose (0, length xs -1) - -prop_index_D xs = - not (null xs) ==> - forAll indices $ \i -> (xs !! i) == D.pack xs `D.index` (fromIntegral i) - where indices = choose (0, length xs -1) - -prop_index_C xs = - not (null xs) ==> - forAll indices $ \i -> (xs !! i) == C.pack xs `C.index` (fromIntegral i) - where indices = choose (0, length xs -1) - -prop_elemIndex xs c = (elemIndex c xs) == fmap fromIntegral (L.elemIndex c (pack xs)) -prop_elemIndexCL xs c = (elemIndex c xs) == (C.elemIndex c (C.pack xs)) - -prop_elemIndices xs c = elemIndices c xs == map fromIntegral (L.elemIndices c (pack xs)) - -prop_count c xs = length (L.elemIndices c xs) == fromIntegral (L.count c xs) - -prop_findIndex xs f = (findIndex f xs) == fmap fromIntegral (L.findIndex f (pack xs)) -prop_findIndicies xs f = (findIndices f xs) == map fromIntegral (L.findIndices f (pack xs)) - -prop_elem xs c = (c `elem` xs) == (c `L.elem` (pack xs)) -prop_notElem xs c = (c `notElem` xs) == (L.notElem c (pack xs)) -prop_elem_notelem xs c = c `L.elem` xs == not (c `L.notElem` xs) - --- prop_filterByte xs c = L.filterByte c xs == L.filter (==c) xs --- prop_filterByte2 xs c = unpack (L.filterByte c xs) == filter (==c) (unpack xs) - --- prop_filterNotByte xs c = L.filterNotByte c xs == L.filter (/=c) xs --- prop_filterNotByte2 xs c = unpack (L.filterNotByte c xs) == filter (/=c) (unpack xs) - -prop_find p xs = find p xs == L.find p (pack xs) - -prop_find_findIndex p xs = - L.find p xs == case L.findIndex p xs of - Just n -> Just (xs `L.index` n) - _ -> Nothing - -prop_isPrefixOf xs ys = isPrefixOf xs ys == (pack xs `L.isPrefixOf` pack ys) - -{- -prop_sort1 xs = sort xs == (unpack . L.sort . pack) xs -prop_sort2 xs = (not (null xs)) ==> (L.head . L.sort . pack $ xs) == minimum xs -prop_sort3 xs = (not (null xs)) ==> (L.last . L.sort . pack $ xs) == maximum xs -prop_sort4 xs ys = - (not (null xs)) ==> - (not (null ys)) ==> - (L.head . L.sort) (L.append (pack xs) (pack ys)) == min (minimum xs) (minimum ys) - -prop_sort5 xs ys = - (not (null xs)) ==> - (not (null ys)) ==> - (L.last . L.sort) (L.append (pack xs) (pack ys)) == max (maximum xs) (maximum ys) - --} - ------------------------------------------------------------------------- --- Misc ByteString properties - -prop_nil1BB = P.length P.empty == 0 -prop_nil2BB = P.unpack P.empty == [] -prop_nil1BB_monoid = P.length mempty == 0 -prop_nil2BB_monoid = P.unpack mempty == [] - -prop_nil1LL_monoid = L.length mempty == 0 -prop_nil2LL_monoid = L.unpack mempty == [] - -prop_tailSBB xs = not (P.null xs) ==> P.tail xs == P.pack (tail (P.unpack xs)) - -prop_nullBB xs = null (P.unpack xs) == P.null xs - -prop_lengthBB xs = P.length xs == length1 xs - where - length1 ys - | P.null ys = 0 - | otherwise = 1 + length1 (P.tail ys) - -prop_lengthSBB xs = length xs == P.length (P.pack xs) - -prop_indexBB xs = - not (null xs) ==> - forAll indices $ \i -> (xs !! i) == P.pack xs `P.index` i - where indices = choose (0, length xs -1) - -prop_unsafeIndexBB xs = - not (null xs) ==> - forAll indices $ \i -> (xs !! i) == P.pack xs `P.unsafeIndex` i - where indices = choose (0, length xs -1) - -prop_mapfusionBB f g xs = P.map f (P.map g xs) == P.map (f . g) xs - -prop_filterBB f xs = P.filter f (P.pack xs) == P.pack (filter f xs) - -prop_filterfusionBB f g xs = P.filter f (P.filter g xs) == P.filter (\c -> f c && g c) xs - -prop_elemSBB x xs = P.elem x (P.pack xs) == elem x xs - -prop_takeSBB i xs = P.take i (P.pack xs) == P.pack (take i xs) -prop_dropSBB i xs = P.drop i (P.pack xs) == P.pack (drop i xs) - -prop_splitAtSBB i xs = -- collect (i >= 0 && i < length xs) $ - P.splitAt i (P.pack xs) == - let (a,b) = splitAt i xs in (P.pack a, P.pack b) - -prop_foldlBB f c xs = P.foldl f c (P.pack xs) == foldl f c xs - where _ = c :: Char - -prop_scanlfoldlBB f z xs = not (P.null xs) ==> P.last (P.scanl f z xs) == P.foldl f z xs - -prop_foldrBB f c xs = P.foldl f c (P.pack xs) == foldl f c xs - where _ = c :: Char - -prop_takeWhileSBB f xs = P.takeWhile f (P.pack xs) == P.pack (takeWhile f xs) -prop_dropWhileSBB f xs = P.dropWhile f (P.pack xs) == P.pack (dropWhile f xs) - -prop_spanSBB f xs = P.span f (P.pack xs) == - let (a,b) = span f xs in (P.pack a, P.pack b) - -prop_breakSBB f xs = P.break f (P.pack xs) == - let (a,b) = break f xs in (P.pack a, P.pack b) - -prop_breakspan_1BB xs c = P.break (== c) xs == P.span (/= c) xs - -prop_linesSBB xs = C.lines (C.pack xs) == map C.pack (lines xs) - -prop_unlinesSBB xss = C.unlines (map C.pack xss) == C.pack (unlines xss) - -prop_wordsSBB xs = - C.words (C.pack xs) == map C.pack (words xs) - -prop_wordsLC xs = - LC.words (LC.pack xs) == map LC.pack (words xs) - -prop_unwordsSBB xss = C.unwords (map C.pack xss) == C.pack (unwords xss) -prop_unwordsSLC xss = LC.unwords (map LC.pack xss) == LC.pack (unwords xss) - -prop_splitWithBB f xs = (l1 == l2 || l1 == l2+1) && - sum (map P.length splits) == P.length xs - l2 - where splits = P.splitWith f xs - l1 = length splits - l2 = P.length (P.filter f xs) - -prop_joinsplitBB c xs = P.intercalate (P.pack [c]) (P.split c xs) == xs - -prop_intercalatePL c x y = - - P.intercalate (P.singleton c) (x : y : []) == - -- intercalate (singleton c) (s1 : s2 : []) - - P.pack (intercalate [c] [P.unpack x,P.unpack y]) - --- prop_linessplitBB xs = --- (not . C.null) xs ==> --- C.lines' xs == C.split '\n' xs - --- false: -{- -prop_linessplit2BB xs = - (not . C.null) xs ==> - C.lines xs == C.split '\n' xs ++ (if C.last xs == '\n' then [C.empty] else []) --} - -prop_splitsplitWithBB c xs = P.split c xs == P.splitWith (== c) xs - -prop_bijectionBB c = (P.w2c . P.c2w) c == id c -prop_bijectionBB' w = (P.c2w . P.w2c) w == id w - -prop_packunpackBB s = (P.unpack . P.pack) s == id s -prop_packunpackBB' s = (P.pack . P.unpack) s == id s - -prop_eq1BB xs = xs == (P.unpack . P.pack $ xs) -prop_eq2BB xs = xs == (xs :: P.ByteString) -prop_eq3BB xs ys = (xs == ys) == (P.unpack xs == P.unpack ys) - -prop_compare1BB xs = (P.pack xs `compare` P.pack xs) == EQ -prop_compare2BB xs c = (P.pack (xs++[c]) `compare` P.pack xs) == GT -prop_compare3BB xs c = (P.pack xs `compare` P.pack (xs++[c])) == LT - -prop_compare4BB xs = (not (null xs)) ==> (P.pack xs `compare` P.empty) == GT -prop_compare5BB xs = (not (null xs)) ==> (P.empty `compare` P.pack xs) == LT -prop_compare6BB xs ys= (not (null ys)) ==> (P.pack (xs++ys) `compare` P.pack xs) == GT - -prop_compare7BB x y = x `compare` y == (C.singleton x `compare` C.singleton y) -prop_compare8BB xs ys = xs `compare` ys == (P.pack xs `compare` P.pack ys) - -prop_consBB c xs = P.unpack (P.cons c (P.pack xs)) == (c:xs) -prop_cons1BB xs = 'X' : xs == C.unpack ('X' `C.cons` (C.pack xs)) -prop_cons2BB xs c = c : xs == P.unpack (c `P.cons` (P.pack xs)) -prop_cons3BB c = C.unpack (C.singleton c) == (c:[]) -prop_cons4BB c = (c `P.cons` P.empty) == P.pack (c:[]) - -prop_snoc1BB xs c = xs ++ [c] == P.unpack ((P.pack xs) `P.snoc` c) - -prop_head1BB xs = (not (null xs)) ==> head xs == (P.head . P.pack) xs -prop_head2BB xs = (not (null xs)) ==> head xs == (P.unsafeHead . P.pack) xs -prop_head3BB xs = not (P.null xs) ==> P.head xs == head (P.unpack xs) - -prop_tailBB xs = (not (null xs)) ==> tail xs == (P.unpack . P.tail . P.pack) xs -prop_tail1BB xs = (not (null xs)) ==> tail xs == (P.unpack . P.unsafeTail. P.pack) xs - -prop_lastBB xs = (not (null xs)) ==> last xs == (P.last . P.pack) xs - -prop_initBB xs = - (not (null xs)) ==> - init xs == (P.unpack . P.init . P.pack) xs - --- prop_null xs = (null xs) ==> null xs == (nullPS (pack xs)) - -prop_append1BB xs = (xs ++ xs) == (P.unpack $ P.pack xs `P.append` P.pack xs) -prop_append2BB xs ys = (xs ++ ys) == (P.unpack $ P.pack xs `P.append` P.pack ys) -prop_append3BB xs ys = P.append xs ys == P.pack (P.unpack xs ++ P.unpack ys) - -prop_append1BB_monoid xs = (xs ++ xs) == (P.unpack $ P.pack xs `mappend` P.pack xs) -prop_append2BB_monoid xs ys = (xs ++ ys) == (P.unpack $ P.pack xs `mappend` P.pack ys) -prop_append3BB_monoid xs ys = mappend xs ys == P.pack (P.unpack xs ++ P.unpack ys) - -prop_append1LL_monoid xs = (xs ++ xs) == (L.unpack $ L.pack xs `mappend` L.pack xs) -prop_append2LL_monoid xs ys = (xs ++ ys) == (L.unpack $ L.pack xs `mappend` L.pack ys) -prop_append3LL_monoid xs ys = mappend xs ys == L.pack (L.unpack xs ++ L.unpack ys) - -prop_map1BB f xs = P.map f (P.pack xs) == P.pack (map f xs) -prop_map2BB f g xs = P.map f (P.map g xs) == P.map (f . g) xs -prop_map3BB f xs = map f xs == (P.unpack . P.map f . P.pack) xs --- prop_mapBB' f xs = P.map' f (P.pack xs) == P.pack (map f xs) - -prop_filter1BB xs = (filter (=='X') xs) == (C.unpack $ C.filter (=='X') (C.pack xs)) -prop_filter2BB p xs = (filter p xs) == (P.unpack $ P.filter p (P.pack xs)) - -prop_findBB p xs = find p xs == P.find p (P.pack xs) - -prop_find_findIndexBB p xs = - P.find p xs == case P.findIndex p xs of - Just n -> Just (xs `P.unsafeIndex` n) - _ -> Nothing - -prop_foldl1BB xs a = ((foldl (\x c -> if c == a then x else c:x) [] xs)) == - (P.unpack $ P.foldl (\x c -> if c == a then x else c `P.cons` x) P.empty (P.pack xs)) -prop_foldl2BB xs = P.foldl (\xs c -> c `P.cons` xs) P.empty (P.pack xs) == P.reverse (P.pack xs) - -prop_foldr1BB xs a = ((foldr (\c x -> if c == a then x else c:x) [] xs)) == - (P.unpack $ P.foldr (\c x -> if c == a then x else c `P.cons` x) - P.empty (P.pack xs)) - -prop_foldr2BB xs = P.foldr (\c xs -> c `P.cons` xs) P.empty (P.pack xs) == (P.pack xs) - -prop_foldl1_1BB xs = - (not . P.null) xs ==> - P.foldl1 (\x c -> if c > x then c else x) xs == - P.foldl (\x c -> if c > x then c else x) 0 xs - -prop_foldl1_2BB xs = - (not . P.null) xs ==> - P.foldl1 const xs == P.head xs - -prop_foldl1_3BB xs = - (not . P.null) xs ==> - P.foldl1 (flip const) xs == P.last xs - -prop_foldr1_1BB xs = - (not . P.null) xs ==> - P.foldr1 (\c x -> if c > x then c else x) xs == - P.foldr (\c x -> if c > x then c else x) 0 xs - -prop_foldr1_2BB xs = - (not . P.null) xs ==> - P.foldr1 (flip const) xs == P.last xs - -prop_foldr1_3BB xs = - (not . P.null) xs ==> - P.foldr1 const xs == P.head xs - -prop_takeWhileBB xs a = (takeWhile (/= a) xs) == (P.unpack . (P.takeWhile (/= a)) . P.pack) xs - -prop_dropWhileBB xs a = (dropWhile (/= a) xs) == (P.unpack . (P.dropWhile (/= a)) . P.pack) xs - -prop_dropWhileCC_isSpace xs = - (dropWhile isSpace xs) == - (C.unpack . (C.dropWhile isSpace) . C.pack) xs - -prop_takeBB xs = (take 10 xs) == (P.unpack . (P.take 10) . P.pack) xs - -prop_dropBB xs = (drop 10 xs) == (P.unpack . (P.drop 10) . P.pack) xs - -prop_splitAtBB i xs = -- collect (i >= 0 && i < length xs) $ - splitAt i xs == - let (x,y) = P.splitAt i (P.pack xs) in (P.unpack x, P.unpack y) - -prop_spanBB xs a = (span (/=a) xs) == (let (x,y) = P.span (/=a) (P.pack xs) - in (P.unpack x, P.unpack y)) - -prop_breakBB xs a = (break (/=a) xs) == (let (x,y) = P.break (/=a) (P.pack xs) - in (P.unpack x, P.unpack y)) - -prop_reverse1BB xs = (reverse xs) == (P.unpack . P.reverse . P.pack) xs -prop_reverse2BB xs = P.reverse (P.pack xs) == P.pack (reverse xs) -prop_reverse3BB xs = reverse (P.unpack xs) == (P.unpack . P.reverse) xs - -prop_elemBB xs a = (a `elem` xs) == (a `P.elem` (P.pack xs)) - -prop_notElemBB c xs = P.notElem c (P.pack xs) == notElem c xs - --- should try to stress it -prop_concat1BB xs = (concat [xs,xs]) == (P.unpack $ P.concat [P.pack xs, P.pack xs]) -prop_concat2BB xs = (concat [xs,[]]) == (P.unpack $ P.concat [P.pack xs, P.pack []]) -prop_concatBB xss = P.concat (map P.pack xss) == P.pack (concat xss) - -prop_concat1BB_monoid xs = (concat [xs,xs]) == (P.unpack $ mconcat [P.pack xs, P.pack xs]) -prop_concat2BB_monoid xs = (concat [xs,[]]) == (P.unpack $ mconcat [P.pack xs, P.pack []]) -prop_concatBB_monoid xss = mconcat (map P.pack xss) == P.pack (concat xss) - -prop_concat1LL_monoid xs = (concat [xs,xs]) == (L.unpack $ mconcat [L.pack xs, L.pack xs]) -prop_concat2LL_monoid xs = (concat [xs,[]]) == (L.unpack $ mconcat [L.pack xs, L.pack []]) -prop_concatLL_monoid xss = mconcat (map L.pack xss) == L.pack (concat xss) - -prop_concatMapBB xs = C.concatMap C.singleton xs == (C.pack . concatMap (:[]) . C.unpack) xs - -prop_anyBB xs a = (any (== a) xs) == (P.any (== a) (P.pack xs)) -prop_allBB xs a = (all (== a) xs) == (P.all (== a) (P.pack xs)) - -prop_linesBB xs = (lines xs) == ((map C.unpack) . C.lines . C.pack) xs - -prop_unlinesBB xs = (unlines.lines) xs == (C.unpack. C.unlines . C.lines .C.pack) xs -prop_unlinesLC xs = (unlines.lines) xs == (LC.unpack. LC.unlines . LC.lines .LC.pack) xs - -prop_wordsBB xs = - (words xs) == ((map C.unpack) . C.words . C.pack) xs --- prop_wordstokensBB xs = C.words xs == C.tokens isSpace xs - -prop_unwordsBB xs = - (C.pack.unwords.words) xs == (C.unwords . C.words .C.pack) xs - -prop_groupBB xs = group xs == (map P.unpack . P.group . P.pack) xs - -prop_groupByBB xs = groupBy (==) xs == (map P.unpack . P.groupBy (==) . P.pack) xs -prop_groupBy1CC xs = groupBy (==) xs == (map C.unpack . C.groupBy (==) . C.pack) xs -prop_groupBy1BB xs = groupBy (/=) xs == (map P.unpack . P.groupBy (/=) . P.pack) xs -prop_groupBy2CC xs = groupBy (/=) xs == (map C.unpack . C.groupBy (/=) . C.pack) xs - -prop_joinBB xs ys = (concat . (intersperse ys) . lines) xs == - (C.unpack $ C.intercalate (C.pack ys) (C.lines (C.pack xs))) - -prop_elemIndex1BB xs = (elemIndex 'X' xs) == (C.elemIndex 'X' (C.pack xs)) -prop_elemIndex2BB xs c = (elemIndex c xs) == (C.elemIndex c (C.pack xs)) - --- prop_lineIndices1BB xs = C.elemIndices '\n' xs == C.lineIndices xs - -prop_countBB c xs = length (P.elemIndices c xs) == P.count c xs - -prop_elemIndexEnd1BB c xs = (P.elemIndexEnd c (P.pack xs)) == - (case P.elemIndex c (P.pack (reverse xs)) of - Nothing -> Nothing - Just i -> Just (length xs -1 -i)) - -prop_elemIndexEnd1CC c xs = (C.elemIndexEnd c (C.pack xs)) == - (case C.elemIndex c (C.pack (reverse xs)) of - Nothing -> Nothing - Just i -> Just (length xs -1 -i)) - -prop_elemIndexEnd2BB c xs = (P.elemIndexEnd c (P.pack xs)) == - ((-) (length xs - 1) `fmap` P.elemIndex c (P.pack $ reverse xs)) - -prop_elemIndicesBB xs c = elemIndices c xs == P.elemIndices c (P.pack xs) - -prop_findIndexBB xs a = (findIndex (==a) xs) == (P.findIndex (==a) (P.pack xs)) - -prop_findIndiciesBB xs c = (findIndices (==c) xs) == (P.findIndices (==c) (P.pack xs)) - --- example properties from QuickCheck.Batch -prop_sort1BB xs = sort xs == (P.unpack . P.sort . P.pack) xs -prop_sort2BB xs = (not (null xs)) ==> (P.head . P.sort . P.pack $ xs) == minimum xs -prop_sort3BB xs = (not (null xs)) ==> (P.last . P.sort . P.pack $ xs) == maximum xs -prop_sort4BB xs ys = - (not (null xs)) ==> - (not (null ys)) ==> - (P.head . P.sort) (P.append (P.pack xs) (P.pack ys)) == min (minimum xs) (minimum ys) -prop_sort5BB xs ys = - (not (null xs)) ==> - (not (null ys)) ==> - (P.last . P.sort) (P.append (P.pack xs) (P.pack ys)) == max (maximum xs) (maximum ys) - -prop_intersperseBB c xs = (intersperse c xs) == (P.unpack $ P.intersperse c (P.pack xs)) - --- prop_transposeBB xs = (transpose xs) == ((map P.unpack) . P.transpose . (map P.pack)) xs - -prop_maximumBB xs = (not (null xs)) ==> (maximum xs) == (P.maximum ( P.pack xs )) -prop_minimumBB xs = (not (null xs)) ==> (minimum xs) == (P.minimum ( P.pack xs )) - --- prop_dropSpaceBB xs = dropWhile isSpace xs == C.unpack (C.dropSpace (C.pack xs)) --- prop_dropSpaceEndBB xs = (C.reverse . (C.dropWhile isSpace) . C.reverse) (C.pack xs) == --- (C.dropSpaceEnd (C.pack xs)) - --- prop_breakSpaceBB xs = --- (let (x,y) = C.breakSpace (C.pack xs) --- in (C.unpack x, C.unpack y)) == (break isSpace xs) - -prop_spanEndBB xs = - (C.spanEnd (not . isSpace) (C.pack xs)) == - (let (x,y) = C.span (not.isSpace) (C.reverse (C.pack xs)) in (C.reverse y,C.reverse x)) - -prop_breakEndBB p xs = P.breakEnd (not.p) xs == P.spanEnd p xs -prop_breakEndCC p xs = C.breakEnd (not.p) xs == C.spanEnd p xs - -{- -prop_breakCharBB c xs = - (break (==c) xs) == - (let (x,y) = C.breakChar c (C.pack xs) in (C.unpack x, C.unpack y)) - -prop_spanCharBB c xs = - (break (/=c) xs) == - (let (x,y) = C.spanChar c (C.pack xs) in (C.unpack x, C.unpack y)) - -prop_spanChar_1BB c xs = - (C.span (==c) xs) == C.spanChar c xs - -prop_wordsBB' xs = - (C.unpack . C.unwords . C.words' . C.pack) xs == - (map (\c -> if isSpace c then ' ' else c) xs) - --- prop_linesBB' xs = (C.unpack . C.unlines' . C.lines' . C.pack) xs == (xs) --} - -prop_unfoldrBB c = - forAll arbitrarySizedIntegral $ \n -> - (fst $ C.unfoldrN n fn c) == (C.pack $ take n $ unfoldr fn c) - where - fn x = Just (x, chr (ord x + 1)) - -prop_prefixBB xs ys = isPrefixOf xs ys == (P.pack xs `P.isPrefixOf` P.pack ys) -prop_suffixBB xs ys = isSuffixOf xs ys == (P.pack xs `P.isSuffixOf` P.pack ys) -prop_suffixLL xs ys = isSuffixOf xs ys == (L.pack xs `L.isSuffixOf` L.pack ys) - -prop_copyBB xs = let p = P.pack xs in P.copy p == p -prop_copyLL xs = let p = L.pack xs in L.copy p == p - -prop_initsBB xs = inits xs == map P.unpack (P.inits (P.pack xs)) - -prop_tailsBB xs = tails xs == map P.unpack (P.tails (P.pack xs)) - -prop_findSubstringsBB s x l - = C.findSubstrings (C.pack p) (C.pack s) == naive_findSubstrings p s - where - _ = l :: Int - _ = x :: Int - - -- we look for some random substring of the test string - p = take (model l) $ drop (model x) s - - -- naive reference implementation - naive_findSubstrings :: String -> String -> [Int] - naive_findSubstrings p s = [x | x <- [0..length s], p `isPrefixOf` drop x s] - -prop_findSubstringBB s x l - = C.findSubstring (C.pack p) (C.pack s) == naive_findSubstring p s - where - _ = l :: Int - _ = x :: Int - - -- we look for some random substring of the test string - p = take (model l) $ drop (model x) s - - -- naive reference implementation - naive_findSubstring :: String -> String -> Maybe Int - naive_findSubstring p s = listToMaybe [x | x <- [0..length s], p `isPrefixOf` drop x s] - --- correspondance between break and breakSubstring -prop_breakSubstringBB c l - = P.break (== c) l == P.breakSubstring (P.singleton c) l - -prop_breakSubstring_isInfixOf s l - = P.isInfixOf s l == if P.null s then True - else case P.breakSubstring s l of - (x,y) | P.null y -> False - | otherwise -> True - -prop_breakSubstring_findSubstring s l - = P.findSubstring s l == if P.null s then Just 0 - else case P.breakSubstring s l of - (x,y) | P.null y -> Nothing - | otherwise -> Just (P.length x) - -prop_replicate1BB c = forAll arbitrarySizedIntegral $ \n -> - P.unpack (P.replicate n c) == replicate n c -prop_replicate2BB c = forAll arbitrarySizedIntegral $ \n -> - P.replicate n c == fst (P.unfoldrN n (\u -> Just (u,u)) c) - -prop_replicate3BB c = P.unpack (P.replicate 0 c) == replicate 0 c - -prop_readintBB n = (fst . fromJust . C.readInt . C.pack . show) n == (n :: Int) -prop_readintLL n = (fst . fromJust . D.readInt . D.pack . show) n == (n :: Int) - -prop_readBB x = (read . show) x == (x :: P.ByteString) -prop_readLL x = (read . show) x == (x :: L.ByteString) - -prop_readint2BB s = - let s' = filter (\c -> c `notElem` ['0'..'9']) s - in C.readInt (C.pack s') == Nothing - -prop_readintegerBB n = (fst . fromJust . C.readInteger . C.pack . show) n == (n :: Integer) -prop_readintegerLL n = (fst . fromJust . D.readInteger . D.pack . show) n == (n :: Integer) - -prop_readinteger2BB s = - let s' = filter (\c -> c `notElem` ['0'..'9']) s - in C.readInteger (C.pack s') == Nothing - --- prop_filterChar1BB c xs = (filter (==c) xs) == ((C.unpack . C.filterChar c . C.pack) xs) --- prop_filterChar2BB c xs = (C.filter (==c) (C.pack xs)) == (C.filterChar c (C.pack xs)) --- prop_filterChar3BB c xs = C.filterChar c xs == C.replicate (C.count c xs) c - --- prop_filterNotChar1BB c xs = (filter (/=c) xs) == ((C.unpack . C.filterNotChar c . C.pack) xs) --- prop_filterNotChar2BB c xs = (C.filter (/=c) (C.pack xs)) == (C.filterNotChar c (C.pack xs)) - --- prop_joinjoinpathBB xs ys c = C.joinWithChar c xs ys == C.join (C.singleton c) [xs,ys] - -prop_zipBB xs ys = zip xs ys == P.zip (P.pack xs) (P.pack ys) -prop_zipLC xs ys = zip xs ys == LC.zip (LC.pack xs) (LC.pack ys) -prop_zip1BB xs ys = P.zip xs ys == zip (P.unpack xs) (P.unpack ys) - -prop_zipWithBB xs ys = P.zipWith (,) xs ys == P.zip xs ys -prop_zipWithCC xs ys = C.zipWith (,) xs ys == C.zip xs ys -prop_zipWithLC xs ys = LC.zipWith (,) xs ys == LC.zip xs ys --- prop_zipWith'BB xs ys = P.pack (P.zipWith (+) xs ys) == P.zipWith' (+) xs ys - -prop_unzipBB x = let (xs,ys) = unzip x in (P.pack xs, P.pack ys) == P.unzip x - ------------------------------------------------------------------------- --- --- And check fusion RULES. --- - -{- -prop_lazylooploop em1 em2 start1 start2 arr = - loopL em2 start2 (loopArr (loopL em1 start1 arr)) == - loopSndAcc (loopL (em1 `fuseEFL` em2) (start1 :*: start2) arr) - where - _ = start1 :: Int - _ = start2 :: Int - -prop_looploop em1 em2 start1 start2 arr = - loopU em2 start2 (loopArr (loopU em1 start1 arr)) == - loopSndAcc (loopU (em1 `fuseEFL` em2) (start1 :*: start2) arr) - where - _ = start1 :: Int - _ = start2 :: Int - ------------------------------------------------------------------------- - --- check associativity of sequence loops -prop_sequenceloops_assoc n m o x y z a1 a2 a3 xs = - - k ((f * g) * h) == k (f * (g * h)) -- associativity - - where - (*) = sequenceLoops - f = (sel n) x a1 - g = (sel m) y a2 - h = (sel o) z a3 - - _ = a1 :: Int; _ = a2 :: Int; _ = a3 :: Int - k g = loopArr (loopWrapper g xs) - --- check wrapper elimination -prop_loop_loop_wrapper_elimination n m x y a1 a2 xs = - loopWrapper g (loopArr (loopWrapper f xs)) == - loopSndAcc (loopWrapper (sequenceLoops f g) xs) - where - f = (sel n) x a1 - g = (sel m) y a2 - _ = a1 :: Int; _ = a2 :: Int - -sel :: Bool - -> (acc -> Word8 -> PairS acc (MaybeS Word8)) - -> acc - -> Ptr Word8 - -> Ptr Word8 - -> Int - -> IO (PairS (PairS acc Int) Int) -sel False = doDownLoop -sel True = doUpLoop - ------------------------------------------------------------------------- --- --- Test fusion forms --- - -prop_up_up_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doUpLoop f1 acc1) (doUpLoop f2 acc2)) == - k (doUpLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs - -prop_down_down_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doDownLoop f1 acc1) (doDownLoop f2 acc2)) == - k (doDownLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int ; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_noAcc_noAcc_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doNoAccLoop f1 acc1) (doNoAccLoop f2 acc2)) == - k (doNoAccLoop (f1 `fuseNoAccNoAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int ; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_noAcc_up_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doNoAccLoop f1 acc1) (doUpLoop f2 acc2)) == - k (doUpLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs - -prop_up_noAcc_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doUpLoop f1 acc1) (doNoAccLoop f2 acc2)) == - k (doUpLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs - -prop_noAcc_down_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doNoAccLoop f1 acc1) (doDownLoop f2 acc2)) == - k (doDownLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_down_noAcc_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doDownLoop f1 acc1) (doNoAccLoop f2 acc2)) == - k (doDownLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs - -prop_map_map_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doMapLoop f1 acc1) (doMapLoop f2 acc2)) == - k (doMapLoop (f1 `fuseMapMapEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_filter_filter_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doFilterLoop f1 acc1) (doFilterLoop f2 acc2)) == - k (doFilterLoop (f1 `fuseFilterFilterEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_map_filter_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doMapLoop f1 acc1) (doFilterLoop f2 acc2)) == - k (doNoAccLoop (f1 `fuseMapFilterEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_filter_map_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doFilterLoop f1 acc1) (doMapLoop f2 acc2)) == - k (doNoAccLoop (f1 `fuseFilterMapEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_map_noAcc_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doMapLoop f1 acc1) (doNoAccLoop f2 acc2)) == - k (doNoAccLoop (f1 `fuseMapNoAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_noAcc_map_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doNoAccLoop f1 acc1) (doMapLoop f2 acc2)) == - k (doNoAccLoop (f1 `fuseNoAccMapEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_map_up_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doMapLoop f1 acc1) (doUpLoop f2 acc2)) == - k (doUpLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_up_map_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doUpLoop f1 acc1) (doMapLoop f2 acc2)) == - k (doUpLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_map_down_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doMapLoop f1 acc1) (doDownLoop f2 acc2)) == - k (doDownLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_down_map_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doDownLoop f1 acc1) (doMapLoop f2 acc2)) == - k (doDownLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_filter_noAcc_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doFilterLoop f1 acc1) (doNoAccLoop f2 acc2)) == - k (doNoAccLoop (f1 `fuseFilterNoAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_noAcc_filter_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doNoAccLoop f1 acc1) (doFilterLoop f2 acc2)) == - k (doNoAccLoop (f1 `fuseNoAccFilterEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_filter_up_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doFilterLoop f1 acc1) (doUpLoop f2 acc2)) == - k (doUpLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_up_filter_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doUpLoop f1 acc1) (doFilterLoop f2 acc2)) == - k (doUpLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_filter_down_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doFilterLoop f1 acc1) (doDownLoop f2 acc2)) == - k (doDownLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_down_filter_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doDownLoop f1 acc1) (doFilterLoop f2 acc2)) == - k (doDownLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - ------------------------------------------------------------------------- - -{- -prop_length_loop_fusion_1 f1 acc1 xs = - P.length (loopArr (loopWrapper (doUpLoop f1 acc1) xs)) == - P.lengthU (loopArr (loopWrapper (doUpLoop f1 acc1) xs)) - where _ = acc1 :: Int - -prop_length_loop_fusion_2 f1 acc1 xs = - P.length (loopArr (loopWrapper (doDownLoop f1 acc1) xs)) == - P.lengthU (loopArr (loopWrapper (doDownLoop f1 acc1) xs)) - where _ = acc1 :: Int - -prop_length_loop_fusion_3 f1 acc1 xs = - P.length (loopArr (loopWrapper (doMapLoop f1 acc1) xs)) == - P.lengthU (loopArr (loopWrapper (doMapLoop f1 acc1) xs)) - where _ = acc1 :: Int - -prop_length_loop_fusion_4 f1 acc1 xs = - P.length (loopArr (loopWrapper (doFilterLoop f1 acc1) xs)) == - P.lengthU (loopArr (loopWrapper (doFilterLoop f1 acc1) xs)) - where _ = acc1 :: Int --} - --} - --- prop_zipwith_spec f p q = --- P.pack (P.zipWith f p q) == P.zipWith' f p q --- where _ = f :: Word8 -> Word8 -> Word8 - --- prop_join_spec c s1 s2 = --- P.join (P.singleton c) (s1 : s2 : []) == P.joinWithByte c s1 s2 - --- prop_break_spec x s = --- P.break ((==) x) s == P.breakByte x s - --- prop_span_spec x s = --- P.span ((==) x) s == P.spanByte x s - ------------------------------------------------------------------------- - --- Test IsString, Show, Read, pack, unpack -prop_isstring x = C.unpack (fromString x :: C.ByteString) == x -prop_isstring_lc x = LC.unpack (fromString x :: LC.ByteString) == x - -prop_showP1 x = show x == show (C.unpack x) -prop_showL1 x = show x == show (LC.unpack x) - -prop_readP1 x = read (show x) == (x :: P.ByteString) -prop_readP2 x = read (show x) == C.pack (x :: String) - -prop_readL1 x = read (show x) == (x :: L.ByteString) -prop_readL2 x = read (show x) == LC.pack (x :: String) - -prop_packunpack_s x = (P.unpack . P.pack) x == x -prop_unpackpack_s x = (P.pack . P.unpack) x == x - -prop_packunpack_c x = (C.unpack . C.pack) x == x -prop_unpackpack_c x = (C.pack . C.unpack) x == x - -prop_packunpack_l x = (L.unpack . L.pack) x == x -prop_unpackpack_l x = (L.pack . L.unpack) x == x - -prop_packunpack_lc x = (LC.unpack . LC.pack) x == x -prop_unpackpack_lc x = (LC.pack . LC.unpack) x == x - -prop_toFromChunks x = (L.fromChunks . L.toChunks) x == x -prop_fromToChunks x = (L.toChunks . L.fromChunks) x == filter (not . P.null) x - -prop_toFromStrict x = (L.fromStrict . L.toStrict) x == x -prop_fromToStrict x = (L.toStrict . L.fromStrict) x == x - -prop_packUptoLenBytes cs = - forAll (choose (0, length cs + 1)) $ \n -> - let (bs, cs') = P.packUptoLenBytes n cs - in P.length bs == min n (length cs) - && take n cs == P.unpack bs - && P.pack (take n cs) == bs - && drop n cs == cs' - -prop_packUptoLenChars cs = - forAll (choose (0, length cs + 1)) $ \n -> - let (bs, cs') = P.packUptoLenChars n cs - in P.length bs == min n (length cs) - && take n cs == C.unpack bs - && C.pack (take n cs) == bs - && drop n cs == cs' - -prop_unpack_s cs = - forAll (choose (0, length cs)) $ \n -> - P.unpack (P.drop n $ P.pack cs) == drop n cs -prop_unpack_c cs = - forAll (choose (0, length cs)) $ \n -> - C.unpack (C.drop n $ C.pack cs) == drop n cs - -prop_unpack_l cs = - forAll (choose (0, length cs)) $ \n -> - L.unpack (L.drop (fromIntegral n) $ L.pack cs) == drop n cs -prop_unpack_lc cs = - forAll (choose (0, length cs)) $ \n -> - LC.unpack (L.drop (fromIntegral n) $ LC.pack cs) == drop n cs - -prop_unpackBytes cs = - forAll (choose (0, length cs)) $ \n -> - P.unpackBytes (P.drop n $ P.pack cs) == drop n cs -prop_unpackChars cs = - forAll (choose (0, length cs)) $ \n -> - P.unpackChars (P.drop n $ C.pack cs) == drop n cs - -prop_unpackBytes_l = - forAll (sized $ \n -> resize (n * 10) arbitrary) $ \cs -> - forAll (choose (0, length cs)) $ \n -> - L.unpackBytes (L.drop (fromIntegral n) $ L.pack cs) == drop n cs -prop_unpackChars_l = - forAll (sized $ \n -> resize (n * 10) arbitrary) $ \cs -> - forAll (choose (0, length cs)) $ \n -> - L.unpackChars (L.drop (fromIntegral n) $ LC.pack cs) == drop n cs - -prop_unpackAppendBytesLazy cs' = - forAll (sized $ \n -> resize (n * 10) arbitrary) $ \cs -> - forAll (choose (0, 2)) $ \n -> - P.unpackAppendBytesLazy (P.drop n $ P.pack cs) cs' == drop n cs ++ cs' -prop_unpackAppendCharsLazy cs' = - forAll (sized $ \n -> resize (n * 10) arbitrary) $ \cs -> - forAll (choose (0, 2)) $ \n -> - P.unpackAppendCharsLazy (P.drop n $ C.pack cs) cs' == drop n cs ++ cs' - -prop_unpackAppendBytesStrict cs cs' = - forAll (choose (0, length cs)) $ \n -> - P.unpackAppendBytesStrict (P.drop n $ P.pack cs) cs' == drop n cs ++ cs' - -prop_unpackAppendCharsStrict cs cs' = - forAll (choose (0, length cs)) $ \n -> - P.unpackAppendCharsStrict (P.drop n $ C.pack cs) cs' == drop n cs ++ cs' - ------------------------------------------------------------------------- --- Unsafe functions - --- Test unsafePackAddress -prop_unsafePackAddress (CByteString x) = unsafePerformIO $ do - let (p,_,_) = P.toForeignPtr (x `P.snoc` 0) - y <- withForeignPtr p $ \(Ptr addr) -> - P.unsafePackAddress addr - return (y == x) - --- Test unsafePackAddressLen -prop_unsafePackAddressLen x = unsafePerformIO $ do - let i = P.length x - (p,_,_) = P.toForeignPtr (x `P.snoc` 0) - y <- withForeignPtr p $ \(Ptr addr) -> - P.unsafePackAddressLen i addr - return (y == x) - -prop_unsafeUseAsCString x = unsafePerformIO $ do - let n = P.length x - y <- P.unsafeUseAsCString x $ \cstr -> - sequence [ do a <- peekElemOff cstr i - let b = x `P.index` i - return (a == fromIntegral b) - | i <- [0.. n-1] ] - return (and y) - -prop_unsafeUseAsCStringLen x = unsafePerformIO $ do - let n = P.length x - y <- P.unsafeUseAsCStringLen x $ \(cstr,_) -> - sequence [ do a <- peekElemOff cstr i - let b = x `P.index` i - return (a == fromIntegral b) - | i <- [0.. n-1] ] - return (and y) - -prop_internal_invariant x = L.invariant x - -prop_useAsCString x = unsafePerformIO $ do - let n = P.length x - y <- P.useAsCString x $ \cstr -> - sequence [ do a <- peekElemOff cstr i - let b = x `P.index` i - return (a == fromIntegral b) - | i <- [0.. n-1] ] - return (and y) - -prop_packCString (CByteString x) = unsafePerformIO $ do - y <- P.useAsCString x $ P.unsafePackCString - return (y == x) - -prop_packCString_safe (CByteString x) = unsafePerformIO $ do - y <- P.useAsCString x $ P.packCString - return (y == x) - -prop_packCStringLen x = unsafePerformIO $ do - y <- P.useAsCStringLen x $ P.unsafePackCStringLen - return (y == x && P.length y == P.length x) - -prop_packCStringLen_safe x = unsafePerformIO $ do - y <- P.useAsCStringLen x $ P.packCStringLen - return (y == x && P.length y == P.length x) - -prop_packMallocCString (CByteString x) = unsafePerformIO $ do - - let (fp,_,_) = P.toForeignPtr x - ptr <- mallocArray0 (P.length x) :: IO (Ptr Word8) - forM_ [0 .. P.length x] $ \n -> pokeElemOff ptr n 0 - withForeignPtr fp $ \qtr -> copyArray ptr qtr (P.length x) - y <- P.unsafePackMallocCString (castPtr ptr) - - let !z = y == x - free ptr `seq` return z - -prop_unsafeFinalize x = - P.length x > 0 ==> - unsafePerformIO $ do - x <- P.unsafeFinalize x - return (x == ()) - -prop_packCStringFinaliser x = unsafePerformIO $ do - y <- P.useAsCString x $ \cstr -> P.unsafePackCStringFinalizer (castPtr cstr) (P.length x) (return ()) - return (y == x) - -prop_fromForeignPtr x = (let (a,b,c) = (P.toForeignPtr x) - in P.fromForeignPtr a b c) == x - ------------------------------------------------------------------------- --- IO - -prop_read_write_file_P x = unsafePerformIO $ do - tid <- myThreadId - let f = "qc-test-"++show tid - bracket - (do P.writeFile f x) - (const $ do removeFile f) - (const $ do y <- P.readFile f - return (x==y)) - -prop_read_write_file_C x = unsafePerformIO $ do - tid <- myThreadId - let f = "qc-test-"++show tid - bracket - (do C.writeFile f x) - (const $ do removeFile f) - (const $ do y <- C.readFile f - return (x==y)) - -prop_read_write_file_L x = unsafePerformIO $ do - tid <- myThreadId - let f = "qc-test-"++show tid - bracket - (do L.writeFile f x) - (const $ do removeFile f) - (const $ do y <- L.readFile f - return (x==y)) - -prop_read_write_file_D x = unsafePerformIO $ do - tid <- myThreadId - let f = "qc-test-"++show tid - bracket - (do D.writeFile f x) - (const $ do removeFile f) - (const $ do y <- D.readFile f - return (x==y)) - ------------------------------------------------------------------------- - -prop_append_file_P x y = unsafePerformIO $ do - tid <- myThreadId - let f = "qc-test-"++show tid - bracket - (do P.writeFile f x - P.appendFile f y) - (const $ do removeFile f) - (const $ do z <- P.readFile f - return (z==(x `P.append` y))) - -prop_append_file_C x y = unsafePerformIO $ do - tid <- myThreadId - let f = "qc-test-"++show tid - bracket - (do C.writeFile f x - C.appendFile f y) - (const $ do removeFile f) - (const $ do z <- C.readFile f - return (z==(x `C.append` y))) - -prop_append_file_L x y = unsafePerformIO $ do - tid <- myThreadId - let f = "qc-test-"++show tid - bracket - (do L.writeFile f x - L.appendFile f y) - (const $ do removeFile f) - (const $ do z <- L.readFile f - return (z==(x `L.append` y))) - -prop_append_file_D x y = unsafePerformIO $ do - tid <- myThreadId - let f = "qc-test-"++show tid - bracket - (do D.writeFile f x - D.appendFile f y) - (const $ do removeFile f) - (const $ do z <- D.readFile f - return (z==(x `D.append` y))) - -prop_packAddress = C.pack "this is a test" - == - C.pack "this is a test" - -prop_isSpaceWord8 (w :: Word8) = isSpace c == P.isSpaceChar8 c - where c = chr (fromIntegral w) - - ------------------------------------------------------------------------- --- The entry point - -main :: IO () -main = defaultMain tests - --- --- And now a list of all the properties to test. --- - -tests = misc_tests - ++ bl_tests - ++ cc_tests - ++ bp_tests - ++ pl_tests - ++ bb_tests - ++ ll_tests - ++ io_tests - ++ rules - --- --- 'morally sound' IO --- -io_tests = - [ testProperty "readFile.writeFile" prop_read_write_file_P - , testProperty "readFile.writeFile" prop_read_write_file_C - , testProperty "readFile.writeFile" prop_read_write_file_L - , testProperty "readFile.writeFile" prop_read_write_file_D - - , testProperty "appendFile " prop_append_file_P - , testProperty "appendFile " prop_append_file_C - , testProperty "appendFile " prop_append_file_L - , testProperty "appendFile " prop_append_file_D - - , testProperty "packAddress " prop_packAddress - - ] - -misc_tests = - [ testProperty "packunpack" prop_packunpack_s - , testProperty "unpackpack" prop_unpackpack_s - , testProperty "packunpack" prop_packunpack_c - , testProperty "unpackpack" prop_unpackpack_c - , testProperty "packunpack" prop_packunpack_l - , testProperty "unpackpack" prop_unpackpack_l - , testProperty "packunpack" prop_packunpack_lc - , testProperty "unpackpack" prop_unpackpack_lc - , testProperty "unpack" prop_unpack_s - , testProperty "unpack" prop_unpack_c - , testProperty "unpack" prop_unpack_l - , testProperty "unpack" prop_unpack_lc - , testProperty "packUptoLenBytes" prop_packUptoLenBytes - , testProperty "packUptoLenChars" prop_packUptoLenChars - , testProperty "unpackBytes" prop_unpackBytes - , testProperty "unpackChars" prop_unpackChars - , testProperty "unpackBytes" prop_unpackBytes_l - , testProperty "unpackChars" prop_unpackChars_l - , testProperty "unpackAppendBytesLazy" prop_unpackAppendBytesLazy - , testProperty "unpackAppendCharsLazy" prop_unpackAppendCharsLazy - , testProperty "unpackAppendBytesStrict"prop_unpackAppendBytesStrict - , testProperty "unpackAppendCharsStrict"prop_unpackAppendCharsStrict - , testProperty "toFromChunks" prop_toFromChunks - , testProperty "fromToChunks" prop_fromToChunks - , testProperty "toFromStrict" prop_toFromStrict - , testProperty "fromToStrict" prop_fromToStrict - - , testProperty "invariant" prop_invariant - , testProperty "unsafe pack address" prop_unsafePackAddress - , testProperty "unsafe pack address len"prop_unsafePackAddressLen - , testProperty "unsafeUseAsCString" prop_unsafeUseAsCString - , testProperty "unsafeUseAsCStringLen" prop_unsafeUseAsCStringLen - , testProperty "useAsCString" prop_useAsCString - , testProperty "packCString" prop_packCString - , testProperty "packCString safe" prop_packCString_safe - , testProperty "packCStringLen" prop_packCStringLen - , testProperty "packCStringLen safe" prop_packCStringLen_safe - , testProperty "packCStringFinaliser" prop_packCStringFinaliser - , testProperty "packMallocString" prop_packMallocCString - , testProperty "unsafeFinalise" prop_unsafeFinalize - , testProperty "invariant" prop_internal_invariant - , testProperty "show 1" prop_showP1 - , testProperty "show 2" prop_showL1 - , testProperty "read 1" prop_readP1 - , testProperty "read 2" prop_readP2 - , testProperty "read 3" prop_readL1 - , testProperty "read 4" prop_readL2 - , testProperty "fromForeignPtr" prop_fromForeignPtr - ] - ------------------------------------------------------------------------- --- ByteString.Lazy <=> List - -bl_tests = - [ testProperty "all" prop_allBL - , testProperty "any" prop_anyBL - , testProperty "append" prop_appendBL - , testProperty "compare" prop_compareBL - , testProperty "concat" prop_concatBL - , testProperty "cons" prop_consBL - , testProperty "eq" prop_eqBL - , testProperty "filter" prop_filterBL - , testProperty "find" prop_findBL - , testProperty "findIndex" prop_findIndexBL - , testProperty "findIndices" prop_findIndicesBL - , testProperty "foldl" prop_foldlBL - , testProperty "foldl'" prop_foldlBL' - , testProperty "foldl1" prop_foldl1BL - , testProperty "foldl1'" prop_foldl1BL' - , testProperty "foldr" prop_foldrBL - , testProperty "foldr1" prop_foldr1BL - , testProperty "mapAccumL" prop_mapAccumLBL - , testProperty "mapAccumR" prop_mapAccumRBL - , testProperty "mapAccumR" prop_mapAccumRDL - , testProperty "mapAccumR" prop_mapAccumRCC - , testProperty "unfoldr" prop_unfoldrBL - , testProperty "unfoldr" prop_unfoldrLC - , testProperty "unfoldr" prop_cycleLC - , testProperty "iterate" prop_iterateLC - , testProperty "iterate" prop_iterateLC_2 - , testProperty "iterate" prop_iterateL - , testProperty "repeat" prop_repeatLC - , testProperty "repeat" prop_repeatL - , testProperty "head" prop_headBL - , testProperty "init" prop_initBL - , testProperty "isPrefixOf" prop_isPrefixOfBL - , testProperty "last" prop_lastBL - , testProperty "length" prop_lengthBL - , testProperty "map" prop_mapBL - , testProperty "maximum" prop_maximumBL - , testProperty "minimum" prop_minimumBL - , testProperty "null" prop_nullBL - , testProperty "reverse" prop_reverseBL - , testProperty "snoc" prop_snocBL - , testProperty "tail" prop_tailBL - , testProperty "transpose" prop_transposeBL - , testProperty "replicate" prop_replicateBL - , testProperty "take" prop_takeBL - , testProperty "drop" prop_dropBL - , testProperty "splitAt" prop_splitAtBL - , testProperty "takeWhile" prop_takeWhileBL - , testProperty "dropWhile" prop_dropWhileBL - , testProperty "break" prop_breakBL - , testProperty "span" prop_spanBL - , testProperty "group" prop_groupBL - , testProperty "groupBy" prop_groupByBL - , testProperty "inits" prop_initsBL - , testProperty "tails" prop_tailsBL - , testProperty "elem" prop_elemBL - , testProperty "notElem" prop_notElemBL - , testProperty "lines" prop_linesBL - , testProperty "elemIndex" prop_elemIndexBL - , testProperty "elemIndices" prop_elemIndicesBL - , testProperty "concatMap" prop_concatMapBL - ] - ------------------------------------------------------------------------- --- ByteString.Lazy <=> ByteString - -cc_tests = - [ testProperty "prop_concatCC" prop_concatCC - , testProperty "prop_nullCC" prop_nullCC - , testProperty "prop_reverseCC" prop_reverseCC - , testProperty "prop_transposeCC" prop_transposeCC - , testProperty "prop_groupCC" prop_groupCC - , testProperty "prop_groupByCC" prop_groupByCC - , testProperty "prop_initsCC" prop_initsCC - , testProperty "prop_tailsCC" prop_tailsCC - , testProperty "prop_allCC" prop_allCC - , testProperty "prop_anyCC" prop_anyCC - , testProperty "prop_appendCC" prop_appendCC - , testProperty "prop_breakCC" prop_breakCC - , testProperty "prop_concatMapCC" prop_concatMapCC - , testProperty "prop_consCC" prop_consCC - , testProperty "prop_consCC'" prop_consCC' - , testProperty "prop_unconsCC" prop_unconsCC - , testProperty "prop_countCC" prop_countCC - , testProperty "prop_dropCC" prop_dropCC - , testProperty "prop_dropWhileCC" prop_dropWhileCC - , testProperty "prop_filterCC" prop_filterCC - , testProperty "prop_findCC" prop_findCC - , testProperty "prop_findIndexCC" prop_findIndexCC - , testProperty "prop_findIndicesCC" prop_findIndicesCC - , testProperty "prop_isPrefixOfCC" prop_isPrefixOfCC - , testProperty "prop_mapCC" prop_mapCC - , testProperty "prop_replicateCC" prop_replicateCC - , testProperty "prop_snocCC" prop_snocCC - , testProperty "prop_spanCC" prop_spanCC - , testProperty "prop_splitCC" prop_splitCC - , testProperty "prop_splitAtCC" prop_splitAtCC - , testProperty "prop_takeCC" prop_takeCC - , testProperty "prop_takeWhileCC" prop_takeWhileCC - , testProperty "prop_elemCC" prop_elemCC - , testProperty "prop_notElemCC" prop_notElemCC - , testProperty "prop_elemIndexCC" prop_elemIndexCC - , testProperty "prop_elemIndicesCC" prop_elemIndicesCC - , testProperty "prop_lengthCC" prop_lengthCC - , testProperty "prop_headCC" prop_headCC - , testProperty "prop_initCC" prop_initCC - , testProperty "prop_lastCC" prop_lastCC - , testProperty "prop_maximumCC" prop_maximumCC - , testProperty "prop_minimumCC" prop_minimumCC - , testProperty "prop_tailCC" prop_tailCC - , testProperty "prop_foldl1CC" prop_foldl1CC - , testProperty "prop_foldl1CC'" prop_foldl1CC' - , testProperty "prop_foldr1CC" prop_foldr1CC - , testProperty "prop_foldr1CC'" prop_foldr1CC' - , testProperty "prop_scanlCC" prop_scanlCC - , testProperty "prop_intersperseCC" prop_intersperseCC - - , testProperty "prop_foldlCC" prop_foldlCC - , testProperty "prop_foldlCC'" prop_foldlCC' - , testProperty "prop_foldrCC" prop_foldrCC - , testProperty "prop_foldrCC'" prop_foldrCC' - , testProperty "prop_mapAccumLCC" prop_mapAccumLCC --- , testProperty "prop_mapIndexedCC" prop_mapIndexedCC --- , testProperty "prop_mapIndexedPL" prop_mapIndexedPL - ] - -bp_tests = - [ testProperty "all" prop_allBP - , testProperty "any" prop_anyBP - , testProperty "append" prop_appendBP - , testProperty "compare" prop_compareBP - , testProperty "concat" prop_concatBP - , testProperty "cons" prop_consBP - , testProperty "cons'" prop_consBP' - , testProperty "uncons" prop_unconsBP - , testProperty "eq" prop_eqBP - , testProperty "filter" prop_filterBP - , testProperty "find" prop_findBP - , testProperty "findIndex" prop_findIndexBP - , testProperty "findIndices" prop_findIndicesBP - , testProperty "foldl" prop_foldlBP - , testProperty "foldl'" prop_foldlBP' - , testProperty "foldl1" prop_foldl1BP - , testProperty "foldl1'" prop_foldl1BP' - , testProperty "foldr" prop_foldrBP - , testProperty "foldr'" prop_foldrBP' - , testProperty "foldr1" prop_foldr1BP - , testProperty "foldr1'" prop_foldr1BP' - , testProperty "mapAccumL" prop_mapAccumLBP --- , testProperty "mapAccumL" prop_mapAccumL_mapIndexedBP - , testProperty "unfoldr" prop_unfoldrBP - , testProperty "unfoldr 2" prop_unfoldr2BP - , testProperty "unfoldr 2" prop_unfoldr2CP - , testProperty "head" prop_headBP - , testProperty "init" prop_initBP - , testProperty "isPrefixOf" prop_isPrefixOfBP - , testProperty "last" prop_lastBP - , testProperty "length" prop_lengthBP - , testProperty "readInt" prop_readIntBP - , testProperty "lines" prop_linesBP - , testProperty "lines \\n" prop_linesNLBP - , testProperty "map" prop_mapBP - , testProperty "maximum " prop_maximumBP - , testProperty "minimum" prop_minimumBP - , testProperty "null" prop_nullBP - , testProperty "reverse" prop_reverseBP - , testProperty "snoc" prop_snocBP - , testProperty "tail" prop_tailBP - , testProperty "scanl" prop_scanlBP - , testProperty "transpose" prop_transposeBP - , testProperty "replicate" prop_replicateBP - , testProperty "take" prop_takeBP - , testProperty "drop" prop_dropBP - , testProperty "splitAt" prop_splitAtBP - , testProperty "takeWhile" prop_takeWhileBP - , testProperty "dropWhile" prop_dropWhileBP - , testProperty "break" prop_breakBP - , testProperty "span" prop_spanBP - , testProperty "split" prop_splitBP - , testProperty "count" prop_countBP - , testProperty "group" prop_groupBP - , testProperty "groupBy" prop_groupByBP - , testProperty "inits" prop_initsBP - , testProperty "tails" prop_tailsBP - , testProperty "elem" prop_elemBP - , testProperty "notElem" prop_notElemBP - , testProperty "elemIndex" prop_elemIndexBP - , testProperty "elemIndices" prop_elemIndicesBP - , testProperty "intersperse" prop_intersperseBP - , testProperty "concatMap" prop_concatMapBP - ] - ------------------------------------------------------------------------- --- ByteString <=> List - -pl_tests = - [ testProperty "all" prop_allPL - , testProperty "any" prop_anyPL - , testProperty "append" prop_appendPL - , testProperty "compare" prop_comparePL - , testProperty "concat" prop_concatPL - , testProperty "cons" prop_consPL - , testProperty "eq" prop_eqPL - , testProperty "filter" prop_filterPL - , testProperty "filter rules"prop_filterPL_rule - , testProperty "filter rules"prop_filterLC_rule - , testProperty "partition" prop_partitionPL - , testProperty "partition" prop_partitionLL - , testProperty "find" prop_findPL - , testProperty "findIndex" prop_findIndexPL - , testProperty "findIndices" prop_findIndicesPL - , testProperty "foldl" prop_foldlPL - , testProperty "foldl'" prop_foldlPL' - , testProperty "foldl1" prop_foldl1PL - , testProperty "foldl1'" prop_foldl1PL' - , testProperty "foldr1" prop_foldr1PL - , testProperty "foldr" prop_foldrPL - , testProperty "mapAccumL" prop_mapAccumLPL - , testProperty "mapAccumR" prop_mapAccumRPL - , testProperty "unfoldr" prop_unfoldrPL - , testProperty "scanl" prop_scanlPL - , testProperty "scanl1" prop_scanl1PL - , testProperty "scanl1" prop_scanl1CL - , testProperty "scanr" prop_scanrCL - , testProperty "scanr" prop_scanrPL - , testProperty "scanr1" prop_scanr1PL - , testProperty "scanr1" prop_scanr1CL - , testProperty "head" prop_headPL - , testProperty "init" prop_initPL - , testProperty "last" prop_lastPL - , testProperty "maximum" prop_maximumPL - , testProperty "minimum" prop_minimumPL - , testProperty "tail" prop_tailPL - , testProperty "zip" prop_zipPL - , testProperty "zip" prop_zipLL - , testProperty "zip" prop_zipCL - , testProperty "unzip" prop_unzipPL - , testProperty "unzip" prop_unzipLL - , testProperty "unzip" prop_unzipCL - , testProperty "zipWith" prop_zipWithPL --- , testProperty "zipWith" prop_zipWithCL - , testProperty "zipWith rules" prop_zipWithPL_rules --- , testProperty "zipWith/zipWith'" prop_zipWithPL' - - , testProperty "isPrefixOf" prop_isPrefixOfPL - , testProperty "isInfixOf" prop_isInfixOfPL - , testProperty "length" prop_lengthPL - , testProperty "map" prop_mapPL - , testProperty "null" prop_nullPL - , testProperty "reverse" prop_reversePL - , testProperty "snoc" prop_snocPL - , testProperty "transpose" prop_transposePL - , testProperty "replicate" prop_replicatePL - , testProperty "take" prop_takePL - , testProperty "drop" prop_dropPL - , testProperty "splitAt" prop_splitAtPL - , testProperty "takeWhile" prop_takeWhilePL - , testProperty "dropWhile" prop_dropWhilePL - , testProperty "break" prop_breakPL - , testProperty "span" prop_spanPL - , testProperty "group" prop_groupPL - , testProperty "groupBy" prop_groupByPL - , testProperty "inits" prop_initsPL - , testProperty "tails" prop_tailsPL - , testProperty "elem" prop_elemPL - , testProperty "notElem" prop_notElemPL - , testProperty "lines" prop_linesPL - , testProperty "elemIndex" prop_elemIndexPL - , testProperty "elemIndex" prop_elemIndexCL - , testProperty "elemIndices" prop_elemIndicesPL - , testProperty "concatMap" prop_concatMapPL - , testProperty "IsString" prop_isstring - , testProperty "IsString LC" prop_isstring_lc - ] - ------------------------------------------------------------------------- --- extra ByteString properties - -bb_tests = - [ testProperty "bijection" prop_bijectionBB - , testProperty "bijection'" prop_bijectionBB' - , testProperty "pack/unpack" prop_packunpackBB - , testProperty "unpack/pack" prop_packunpackBB' - , testProperty "eq 1" prop_eq1BB - , testProperty "eq 2" prop_eq2BB - , testProperty "eq 3" prop_eq3BB - , testProperty "compare 1" prop_compare1BB - , testProperty "compare 2" prop_compare2BB - , testProperty "compare 3" prop_compare3BB - , testProperty "compare 4" prop_compare4BB - , testProperty "compare 5" prop_compare5BB - , testProperty "compare 6" prop_compare6BB - , testProperty "compare 7" prop_compare7BB - , testProperty "compare 7" prop_compare7LL - , testProperty "compare 8" prop_compare8BB - , testProperty "empty 1" prop_nil1BB - , testProperty "empty 2" prop_nil2BB - , testProperty "empty 1 monoid" prop_nil1LL_monoid - , testProperty "empty 2 monoid" prop_nil2LL_monoid - , testProperty "empty 1 monoid" prop_nil1BB_monoid - , testProperty "empty 2 monoid" prop_nil2BB_monoid - - , testProperty "null" prop_nullBB - , testProperty "length 1" prop_lengthBB - , testProperty "length 2" prop_lengthSBB - , testProperty "cons 1" prop_consBB - , testProperty "cons 2" prop_cons1BB - , testProperty "cons 3" prop_cons2BB - , testProperty "cons 4" prop_cons3BB - , testProperty "cons 5" prop_cons4BB - , testProperty "snoc" prop_snoc1BB - , testProperty "head 1" prop_head1BB - , testProperty "head 2" prop_head2BB - , testProperty "head 3" prop_head3BB - , testProperty "tail" prop_tailBB - , testProperty "tail 1" prop_tail1BB - , testProperty "last" prop_lastBB - , testProperty "init" prop_initBB - , testProperty "append 1" prop_append1BB - , testProperty "append 2" prop_append2BB - , testProperty "append 3" prop_append3BB - , testProperty "mappend 1" prop_append1BB_monoid - , testProperty "mappend 2" prop_append2BB_monoid - , testProperty "mappend 3" prop_append3BB_monoid - - , testProperty "map 1" prop_map1BB - , testProperty "map 2" prop_map2BB - , testProperty "map 3" prop_map3BB - , testProperty "filter1" prop_filter1BB - , testProperty "filter2" prop_filter2BB - , testProperty "map fusion" prop_mapfusionBB - , testProperty "filter fusion" prop_filterfusionBB - , testProperty "reverse 1" prop_reverse1BB - , testProperty "reverse 2" prop_reverse2BB - , testProperty "reverse 3" prop_reverse3BB - , testProperty "foldl 1" prop_foldl1BB - , testProperty "foldl 2" prop_foldl2BB - , testProperty "foldr 1" prop_foldr1BB - , testProperty "foldr 2" prop_foldr2BB - , testProperty "foldl1 1" prop_foldl1_1BB - , testProperty "foldl1 2" prop_foldl1_2BB - , testProperty "foldl1 3" prop_foldl1_3BB - , testProperty "foldr1 1" prop_foldr1_1BB - , testProperty "foldr1 2" prop_foldr1_2BB - , testProperty "foldr1 3" prop_foldr1_3BB - , testProperty "scanl/foldl" prop_scanlfoldlBB - , testProperty "all" prop_allBB - , testProperty "any" prop_anyBB - , testProperty "take" prop_takeBB - , testProperty "drop" prop_dropBB - , testProperty "takeWhile" prop_takeWhileBB - , testProperty "dropWhile" prop_dropWhileBB - , testProperty "dropWhile" prop_dropWhileCC_isSpace - , testProperty "splitAt" prop_splitAtBB - , testProperty "span" prop_spanBB - , testProperty "break" prop_breakBB - , testProperty "elem" prop_elemBB - , testProperty "notElem" prop_notElemBB - - , testProperty "concat 1" prop_concat1BB - , testProperty "concat 2" prop_concat2BB - , testProperty "concat 3" prop_concatBB - , testProperty "mconcat 1" prop_concat1BB_monoid - , testProperty "mconcat 2" prop_concat2BB_monoid - , testProperty "mconcat 3" prop_concatBB_monoid - - , testProperty "mconcat 1" prop_concat1LL_monoid - , testProperty "mconcat 2" prop_concat2LL_monoid - , testProperty "mconcat 3" prop_concatLL_monoid - - , testProperty "lines" prop_linesBB - , testProperty "unlines" prop_unlinesBB - , testProperty "unlines" prop_unlinesLC - , testProperty "words" prop_wordsBB - , testProperty "words" prop_wordsLC - , testProperty "unwords" prop_unwordsBB - , testProperty "group" prop_groupBB - , testProperty "groupBy 0" prop_groupByBB - , testProperty "groupBy 1" prop_groupBy1CC - , testProperty "groupBy 2" prop_groupBy1BB - , testProperty "groupBy 3" prop_groupBy2CC - , testProperty "join" prop_joinBB - , testProperty "elemIndex 1" prop_elemIndex1BB - , testProperty "elemIndex 2" prop_elemIndex2BB - , testProperty "findIndex" prop_findIndexBB - , testProperty "findIndicies" prop_findIndiciesBB - , testProperty "elemIndices" prop_elemIndicesBB - , testProperty "find" prop_findBB - , testProperty "find/findIndex" prop_find_findIndexBB - , testProperty "sort 1" prop_sort1BB - , testProperty "sort 2" prop_sort2BB - , testProperty "sort 3" prop_sort3BB - , testProperty "sort 4" prop_sort4BB - , testProperty "sort 5" prop_sort5BB - , testProperty "intersperse" prop_intersperseBB - , testProperty "maximum" prop_maximumBB - , testProperty "minimum" prop_minimumBB --- , testProperty "breakChar" prop_breakCharBB --- , testProperty "spanChar 1" prop_spanCharBB --- , testProperty "spanChar 2" prop_spanChar_1BB --- , testProperty "breakSpace" prop_breakSpaceBB --- , testProperty "dropSpace" prop_dropSpaceBB - , testProperty "spanEnd" prop_spanEndBB - , testProperty "breakEnd" prop_breakEndBB - , testProperty "breakEnd" prop_breakEndCC - , testProperty "elemIndexEnd 1" prop_elemIndexEnd1BB - , testProperty "elemIndexEnd 1" prop_elemIndexEnd1CC - , testProperty "elemIndexEnd 2" prop_elemIndexEnd2BB --- , testProperty "words'" prop_wordsBB' --- , testProperty "lines'" prop_linesBB' --- , testProperty "dropSpaceEnd" prop_dropSpaceEndBB - , testProperty "unfoldr" prop_unfoldrBB - , testProperty "prefix" prop_prefixBB - , testProperty "suffix" prop_suffixBB - , testProperty "suffix" prop_suffixLL - , testProperty "copy" prop_copyBB - , testProperty "copy" prop_copyLL - , testProperty "inits" prop_initsBB - , testProperty "tails" prop_tailsBB - , testProperty "findSubstrings "prop_findSubstringsBB - , testProperty "findSubstring "prop_findSubstringBB - , testProperty "breakSubstring 1"prop_breakSubstringBB - , testProperty "breakSubstring 2"prop_breakSubstring_findSubstring - , testProperty "breakSubstring 3"prop_breakSubstring_isInfixOf - - , testProperty "replicate1" prop_replicate1BB - , testProperty "replicate2" prop_replicate2BB - , testProperty "replicate3" prop_replicate3BB - , testProperty "readInt" prop_readintBB - , testProperty "readInt 2" prop_readint2BB - , testProperty "readInteger" prop_readintegerBB - , testProperty "readInteger 2" prop_readinteger2BB - , testProperty "read" prop_readLL - , testProperty "read" prop_readBB - , testProperty "Lazy.readInt" prop_readintLL - , testProperty "Lazy.readInt" prop_readintLL - , testProperty "Lazy.readInteger" prop_readintegerLL - , testProperty "mconcat 1" prop_append1LL_monoid - , testProperty "mconcat 2" prop_append2LL_monoid - , testProperty "mconcat 3" prop_append3LL_monoid --- , testProperty "filterChar1" prop_filterChar1BB --- , testProperty "filterChar2" prop_filterChar2BB --- , testProperty "filterChar3" prop_filterChar3BB --- , testProperty "filterNotChar1" prop_filterNotChar1BB --- , testProperty "filterNotChar2" prop_filterNotChar2BB - , testProperty "tail" prop_tailSBB - , testProperty "index" prop_indexBB - , testProperty "unsafeIndex" prop_unsafeIndexBB --- , testProperty "map'" prop_mapBB' - , testProperty "filter" prop_filterBB - , testProperty "elem" prop_elemSBB - , testProperty "take" prop_takeSBB - , testProperty "drop" prop_dropSBB - , testProperty "splitAt" prop_splitAtSBB - , testProperty "foldl" prop_foldlBB - , testProperty "foldr" prop_foldrBB - , testProperty "takeWhile " prop_takeWhileSBB - , testProperty "dropWhile " prop_dropWhileSBB - , testProperty "span " prop_spanSBB - , testProperty "break " prop_breakSBB - , testProperty "breakspan" prop_breakspan_1BB - , testProperty "lines " prop_linesSBB - , testProperty "unlines " prop_unlinesSBB - , testProperty "words " prop_wordsSBB - , testProperty "unwords " prop_unwordsSBB - , testProperty "unwords " prop_unwordsSLC --- , testProperty "wordstokens" prop_wordstokensBB - , testProperty "splitWith" prop_splitWithBB - , testProperty "joinsplit" prop_joinsplitBB - , testProperty "intercalate" prop_intercalatePL --- , testProperty "lineIndices" prop_lineIndices1BB - , testProperty "count" prop_countBB --- , testProperty "linessplit" prop_linessplit2BB - , testProperty "splitsplitWith" prop_splitsplitWithBB --- , testProperty "joinjoinpath" prop_joinjoinpathBB - , testProperty "zip" prop_zipBB - , testProperty "zip" prop_zipLC - , testProperty "zip1" prop_zip1BB - , testProperty "zipWith" prop_zipWithBB - , testProperty "zipWith" prop_zipWithCC - , testProperty "zipWith" prop_zipWithLC --- , testProperty "zipWith'" prop_zipWith'BB - , testProperty "unzip" prop_unzipBB - , testProperty "concatMap" prop_concatMapBB --- , testProperty "join/joinByte" prop_join_spec --- , testProperty "span/spanByte" prop_span_spec --- , testProperty "break/breakByte"prop_break_spec - ] - ------------------------------------------------------------------------- --- Fusion rules - -{- -fusion_tests = --- v1 fusion - [ ("lazy loop/loop fusion" prop_lazylooploop - , ("loop/loop fusion" prop_looploop - --- v2 fusion - , testProperty "loop/loop wrapper elim" prop_loop_loop_wrapper_elimination - , testProperty "sequence association" prop_sequenceloops_assoc - - , testProperty "up/up loop fusion" prop_up_up_loop_fusion - , testProperty "down/down loop fusion" prop_down_down_loop_fusion - , testProperty "noAcc/noAcc loop fusion" prop_noAcc_noAcc_loop_fusion - , testProperty "noAcc/up loop fusion" prop_noAcc_up_loop_fusion - , testProperty "up/noAcc loop fusion" prop_up_noAcc_loop_fusion - , testProperty "noAcc/down loop fusion" prop_noAcc_down_loop_fusion - , testProperty "down/noAcc loop fusion" prop_down_noAcc_loop_fusion - , testProperty "map/map loop fusion" prop_map_map_loop_fusion - , testProperty "filter/filter loop fusion" prop_filter_filter_loop_fusion - , testProperty "map/filter loop fusion" prop_map_filter_loop_fusion - , testProperty "filter/map loop fusion" prop_filter_map_loop_fusion - , testProperty "map/noAcc loop fusion" prop_map_noAcc_loop_fusion - , testProperty "noAcc/map loop fusion" prop_noAcc_map_loop_fusion - , testProperty "map/up loop fusion" prop_map_up_loop_fusion - , testProperty "up/map loop fusion" prop_up_map_loop_fusion - , testProperty "map/down loop fusion" prop_map_down_fusion - , testProperty "down/map loop fusion" prop_down_map_loop_fusion - , testProperty "filter/noAcc loop fusion" prop_filter_noAcc_loop_fusion - , testProperty "noAcc/filter loop fusion" prop_noAcc_filter_loop_fusion - , testProperty "filter/up loop fusion" prop_filter_up_loop_fusion - , testProperty "up/filter loop fusion" prop_up_filter_loop_fusion - , testProperty "filter/down loop fusion" prop_filter_down_fusion - , testProperty "down/filter loop fusion" prop_down_filter_loop_fusion - -{- - , testProperty "length/loop fusion" prop_length_loop_fusion_1 - , testProperty "length/loop fusion" prop_length_loop_fusion_2 - , testProperty "length/loop fusion" prop_length_loop_fusion_3 - , testProperty "length/loop fusion" prop_length_loop_fusion_4 --} - --- , testProperty "zipwith/spec" prop_zipwith_spec - ] - --} - - ------------------------------------------------------------------------- --- Extra lazy properties - -ll_tests = - [ testProperty "eq 1" prop_eq1 - , testProperty "eq 2" prop_eq2 - , testProperty "eq 3" prop_eq3 - , testProperty "eq refl" prop_eq_refl - , testProperty "eq symm" prop_eq_symm - , testProperty "compare 1" prop_compare1 - , testProperty "compare 2" prop_compare2 - , testProperty "compare 3" prop_compare3 - , testProperty "compare 4" prop_compare4 - , testProperty "compare 5" prop_compare5 - , testProperty "compare 6" prop_compare6 - , testProperty "compare 7" prop_compare7 - , testProperty "compare 8" prop_compare8 - , testProperty "empty 1" prop_empty1 - , testProperty "empty 2" prop_empty2 - , testProperty "pack/unpack" prop_packunpack - , testProperty "unpack/pack" prop_unpackpack - , testProperty "null" prop_null - , testProperty "length 1" prop_length1 - , testProperty "length 2" prop_length2 - , testProperty "cons 1" prop_cons1 - , testProperty "cons 2" prop_cons2 - , testProperty "cons 3" prop_cons3 - , testProperty "cons 4" prop_cons4 - , testProperty "snoc" prop_snoc1 - , testProperty "head/pack" prop_head - , testProperty "head/unpack" prop_head1 - , testProperty "tail/pack" prop_tail - , testProperty "tail/unpack" prop_tail1 - , testProperty "last" prop_last - , testProperty "init" prop_init - , testProperty "append 1" prop_append1 - , testProperty "append 2" prop_append2 - , testProperty "append 3" prop_append3 - , testProperty "map 1" prop_map1 - , testProperty "map 2" prop_map2 - , testProperty "map 3" prop_map3 - , testProperty "filter 1" prop_filter1 - , testProperty "filter 2" prop_filter2 - , testProperty "reverse" prop_reverse - , testProperty "reverse1" prop_reverse1 - , testProperty "reverse2" prop_reverse2 - , testProperty "transpose" prop_transpose - , testProperty "foldl" prop_foldl - , testProperty "foldl/reverse" prop_foldl_1 - , testProperty "foldr" prop_foldr - , testProperty "foldr/id" prop_foldr_1 - , testProperty "foldl1/foldl" prop_foldl1_1 - , testProperty "foldl1/head" prop_foldl1_2 - , testProperty "foldl1/tail" prop_foldl1_3 - , testProperty "foldr1/foldr" prop_foldr1_1 - , testProperty "foldr1/last" prop_foldr1_2 - , testProperty "foldr1/head" prop_foldr1_3 - , testProperty "concat 1" prop_concat1 - , testProperty "concat 2" prop_concat2 - , testProperty "concat/pack" prop_concat3 - , testProperty "any" prop_any - , testProperty "all" prop_all - , testProperty "maximum" prop_maximum - , testProperty "minimum" prop_minimum - , testProperty "replicate 1" prop_replicate1 - , testProperty "replicate 2" prop_replicate2 - , testProperty "take" prop_take1 - , testProperty "drop" prop_drop1 - , testProperty "splitAt" prop_drop1 - , testProperty "takeWhile" prop_takeWhile - , testProperty "dropWhile" prop_dropWhile - , testProperty "break" prop_break - , testProperty "span" prop_span - , testProperty "splitAt" prop_splitAt - , testProperty "break/span" prop_breakspan --- , testProperty "break/breakByte" prop_breakByte --- , testProperty "span/spanByte" prop_spanByte - , testProperty "split" prop_split - , testProperty "splitWith" prop_splitWith - , testProperty "splitWith" prop_splitWith_D - , testProperty "splitWith" prop_splitWith_C - , testProperty "join.split/id" prop_joinsplit --- , testProperty "join/joinByte" prop_joinjoinByte - , testProperty "group" prop_group - , testProperty "groupBy" prop_groupBy - , testProperty "groupBy" prop_groupBy_LC - , testProperty "index" prop_index - , testProperty "index" prop_index_D - , testProperty "index" prop_index_C - , testProperty "elemIndex" prop_elemIndex - , testProperty "elemIndices" prop_elemIndices - , testProperty "count/elemIndices" prop_count - , testProperty "findIndex" prop_findIndex - , testProperty "findIndices" prop_findIndicies - , testProperty "find" prop_find - , testProperty "find/findIndex" prop_find_findIndex - , testProperty "elem" prop_elem - , testProperty "notElem" prop_notElem - , testProperty "elem/notElem" prop_elem_notelem --- , testProperty "filterByte 1" prop_filterByte --- , testProperty "filterByte 2" prop_filterByte2 --- , testProperty "filterNotByte 1" prop_filterNotByte --- , testProperty "filterNotByte 2" prop_filterNotByte2 - , testProperty "isPrefixOf" prop_isPrefixOf - , testProperty "concatMap" prop_concatMap - , testProperty "isSpace" prop_isSpaceWord8 - ] +{-# LANGUAGE AllowAmbiguousTypes #-} +-- We need @AllowAmbiguousTypes@ in order to be able to use @TypeApplications@ +-- to disambiguate the desired instance of class methods whose instance cannot +-- be inferred from the caller's context. We would otherwise have to use +-- proxy arguments. Here the 'RdInt' class methods used to generate tests for +-- all the various 'readInt' types require explicit type applications. + +module Properties (testSuite) where + +import Prelude hiding (head, tail) +import Foreign.C.String (withCString) +import Foreign.Storable +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import GHC.Ptr +import Test.Tasty.QuickCheck +import Control.Applicative +import Control.Monad +import Control.Concurrent +import Control.Exception +import System.Posix.Internals (c_unlink) + +import qualified Data.List as List +import Data.Char +import Data.Word +import Data.Maybe +import Data.Either (isLeft) +import Data.Bits (finiteBitSize, bit) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Semigroup +import GHC.Exts (Int(..), newPinnedByteArray#, unsafeFreezeByteArray#) +import GHC.ST (ST(..), runST) + +import Text.Printf +import Data.String + +import System.Environment +import System.IO + +import Data.ByteString.Lazy (ByteString(..), pack , unpack) +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.Internal (ByteString(..)) + +import qualified Data.ByteString as P +import qualified Data.ByteString.Internal as P +import qualified Data.ByteString.Unsafe as P +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Short as Short + +import qualified Data.ByteString.Lazy.Char8 as LC +import qualified Data.ByteString.Lazy.Char8 as D + +import qualified Data.ByteString.Lazy.Internal as L + +import QuickCheckUtils +import Test.Tasty +import Test.Tasty.QuickCheck + +import qualified Properties.ShortByteString as PropSBS +import qualified Properties.ByteString as PropBS +import qualified Properties.ByteStringChar8 as PropBS8 +import qualified Properties.ByteStringLazy as PropBL +import qualified Properties.ByteStringLazyChar8 as PropBL8 + +prop_unsafeIndexBB xs = + not (null xs) ==> + forAll indices $ \i -> (xs !! i) == P.pack xs `P.unsafeIndex` i + where indices = choose (0, length xs -1) + +prop_bijectionBB (Char8 c) = (P.w2c . P.c2w) c == id c +prop_bijectionBB' w = (P.c2w . P.w2c) w == id w + +prop_unsafeHead xs = not (P.null xs) ==> P.head xs === P.unsafeHead xs +prop_unsafeTail xs = not (P.null xs) ==> P.tail xs === P.unsafeTail xs +prop_unsafeLast xs = not (P.null xs) ==> P.last xs === P.unsafeLast xs +prop_unsafeInit xs = not (P.null xs) ==> P.init xs === P.unsafeInit xs + +prop_lines_empty_invariant = + True === case LC.lines (LC.pack "\nfoo\n") of + Empty : _ -> True + _ -> False + +prop_lines_lazy = + take 2 (LC.lines (LC.append (LC.pack "a\nb\n") undefined)) === [LC.pack "a", LC.pack "b"] + +prop_lines_lazy2 = + c === case LC.lines (Chunk c undefined) of + Chunk c _ : _ -> c + _ -> P.empty + where + c = C.pack "etc..." + +prop_lines_lazy3 = + c === case LC.lines d of + Chunk c _ : _ -> c + _ -> P.empty + where + c = C.pack "etc..." + d = Chunk c d + +prop_strip x = C.strip x == (C.dropSpace . C.reverse . C.dropSpace . C.reverse) x + +class (Bounded a, Integral a, Show a) => RdInt a where + rdIntC :: C.ByteString -> Maybe (a, C.ByteString) + rdIntD :: D.ByteString -> Maybe (a, D.ByteString) + +instance RdInt Int where { rdIntC = C.readInt; rdIntD = D.readInt } +instance RdInt Int8 where { rdIntC = C.readInt8; rdIntD = D.readInt8 } +instance RdInt Int16 where { rdIntC = C.readInt16; rdIntD = D.readInt16 } +instance RdInt Int32 where { rdIntC = C.readInt32; rdIntD = D.readInt32 } +instance RdInt Int64 where { rdIntC = C.readInt64; rdIntD = D.readInt64 } +-- +instance RdInt Word where { rdIntC = C.readWord; rdIntD = D.readWord } +instance RdInt Word8 where { rdIntC = C.readWord8; rdIntD = D.readWord8 } +instance RdInt Word16 where { rdIntC = C.readWord16; rdIntD = D.readWord16 } +instance RdInt Word32 where { rdIntC = C.readWord32; rdIntD = D.readWord32 } +instance RdInt Word64 where { rdIntC = C.readWord64; rdIntD = D.readWord64 } + +smax :: forall a. (Bounded a, Show a) => String +smax = show $ maxBound @a +smax1 :: forall a. (Bounded a, Integral a) => String +smax1 = show $ fromIntegral @a @Integer maxBound + 1 +smax10 :: forall a. (Bounded a, Integral a) => String +smax10 = show $ fromIntegral @a @Integer maxBound + 10 + +smin :: forall a. (Bounded a, Show a) => String +smin = show (minBound @a) +smin1 :: forall a. (Bounded a, Integral a) => String +smin1 = show $ fromIntegral @a @Integer minBound - 1 +smin10 :: forall a. (Bounded a, Integral a) => String +smin10 = show $ fromIntegral @a @Integer minBound - 10 + +-- Ensure that readWord64 and readInteger over lazy ByteStrings are not +-- excessively strict. +prop_readWordSafe = (fst . fromJust . D.readWord64) (Chunk (C.pack "1z") Empty) == 1 +prop_readWordUnsafe = (fst . fromJust . D.readWord64) (Chunk (C.pack "2z") undefined) == 2 +prop_readIntegerSafe = (fst . fromJust . D.readInteger) (Chunk (C.pack "1z") Empty) == 1 +prop_readIntegerUnsafe = (fst . fromJust . D.readInteger) (Chunk (C.pack "2z") undefined) == 2 +prop_readNaturalSafe = (fst . fromJust . D.readNatural) (Chunk (C.pack "1z") Empty) == 1 +prop_readNaturalUnsafe = (fst . fromJust . D.readNatural) (Chunk (C.pack "2z") undefined) == 2 +prop_readIntBoundsCC = rdWordBounds @Word + && rdWordBounds @Word8 + && rdWordBounds @Word16 + && rdWordBounds @Word32 + && rdWordBounds @Word64 + && rdIntBounds @Int + && rdIntBounds @Int8 + && rdIntBounds @Int16 + && rdIntBounds @Int32 + && rdIntBounds @Int64 + where + tailStr = " tail" + zeroStr = "000000000000000000000000000" + spack s = C.pack $ s ++ tailStr + spackPlus s = C.pack $ '+' : (s ++ tailStr) + spackMinus s = C.pack $ '-' : (s ++ tailStr) + spackLong s = C.pack $ s ++ zeroStr ++ tailStr + spackZeros s = case s of + '+':num -> C.pack $ '+' : zeroStr ++ num ++ tailStr + '-':num -> C.pack $ '-' : zeroStr ++ num ++ tailStr + num -> C.pack $ zeroStr ++ num ++ tailStr + good i = Just (i, C.pack tailStr) + -- + rdWordBounds :: forall a. RdInt a => Bool + rdWordBounds = + -- Upper bound + rdIntC @a (spack (smax @a)) == good maxBound + -- With leading zeros + && rdIntC @a (spackZeros (smax @a)) == good maxBound + -- Overflow in last digit + && rdIntC @a (spack (smax1 @a)) == Nothing + -- Overflow in 2nd-last digit + && rdIntC @a (spack (smax10 @a)) == Nothing + -- Trailing zeros + && rdIntC @a (spackLong (smax @a)) == Nothing + -- + rdIntBounds :: forall a. RdInt a => Bool + rdIntBounds = + rdWordBounds @a + -- Lower bound + && rdIntC @a (spack (smin @a)) == good minBound + -- With leading signs + && rdIntC @a (spackPlus (smax @a)) == good maxBound + && rdIntC @a (spackMinus (smax @a)) == good (negate maxBound) + -- With leading zeros + && rdIntC @a (spackZeros (smax @a)) == good maxBound + -- Underflow in last digit + && rdIntC @a (spack (smin1 @a)) == Nothing + -- Underflow in 2nd-last digit + && rdIntC @a (spack (smin10 @a)) == Nothing + -- Trailing zeros + && rdIntC @a (spackLong (smin @a)) == Nothing + +prop_readIntBoundsLC = rdWordBounds @Word + && rdWordBounds @Word8 + && rdWordBounds @Word16 + && rdWordBounds @Word32 + && rdWordBounds @Word64 + && rdIntBounds @Int + && rdIntBounds @Int8 + && rdIntBounds @Int16 + && rdIntBounds @Int32 + && rdIntBounds @Int64 + where + tailStr = " tail" + zeroStr = "000000000000000000000000000" + spack s = LC.pack $ s ++ tailStr + spackPlus s = LC.singleton '+' `D.append` LC.pack s `D.append` LC.pack tailStr + spackMinus s = LC.singleton '-' `D.append` LC.pack s `D.append` LC.pack tailStr + spackLong1 s = LC.pack s `D.append` LC.pack zeroStr `D.append` LC.pack tailStr + spackLong2 s = LC.pack (s ++ zeroStr) `D.append` LC.pack tailStr + spackZeros s = case s of + '+':num -> LC.pack ('+' : zeroStr) `D.append` LC.pack (num ++ tailStr) + '-':num -> LC.pack ('-' : zeroStr) `D.append` LC.pack (num ++ tailStr) + num -> LC.pack $ zeroStr ++ num ++ tailStr + good i = Just (i, LC.pack tailStr) + -- + rdWordBounds :: forall a. RdInt a => Bool + rdWordBounds = + -- Upper bound + rdIntD @a (spack (smax @a)) == good maxBound + -- With leading zeros + && rdIntD @a (spackZeros (smax @a)) == good maxBound + -- Overflow in last digit + && rdIntD @a (spack (smax1 @a)) == Nothing + -- Overflow in 2nd-last digit + && rdIntD @a (spack (smax10 @a)) == Nothing + -- Overflow across chunk boundary + && rdIntD @a (spackLong1 (smax @a)) == Nothing + -- Overflow within chunk + && rdIntD @a (spackLong2 (smax @a)) == Nothing + -- Sign with no digits + && rdIntD @a (LC.pack "+ foo") == Nothing + && rdIntD @a (LC.pack "-bar") == Nothing + -- + rdIntBounds :: forall a. RdInt a => Bool + rdIntBounds = + rdWordBounds @a + -- Lower bound + && rdIntD @a (spack (smin @a)) == good minBound + -- With leading signs + && rdIntD @a (spackPlus (smax @a)) == good maxBound + && rdIntD @a (spackMinus (smax @a)) == good (negate maxBound) + -- With leading zeros + && rdIntD @a (spackZeros (smin @a)) == good minBound + -- Overflow in last digit + && rdIntD @a (spack (smin1 @a)) == Nothing + -- Overflow in 2nd-last digit + && rdIntD @a (spack (smin10 @a)) == Nothing + -- Overflow across chunk boundary + && rdIntD @a (spackLong1 (smin @a)) == Nothing + -- Overflow within chunk + && rdIntD @a (spackLong2 (smin @a)) == Nothing + +------------------------------------------------------------------------ + +expectSizeOverflow :: a -> Property +expectSizeOverflow val = ioProperty $ do + isLeft <$> try @P.SizeOverflowException (evaluate val) + +prop_checkedAdd = forAll (vectorOf 2 nonNeg) $ \[x, y] -> if oflo x y + then expectSizeOverflow (P.checkedAdd "" x y) + else property $ P.checkedAdd "" x y == x + y + where nonNeg = choose (0, (maxBound @Int)) + oflo x y = toInteger x + toInteger y /= toInteger @Int (x + y) + +multCompl :: Int -> Gen Int +multCompl x = choose (0, fromInteger @Int maxc) + -- This choice creates products with magnitude roughly in the range + -- [0..5*(maxBound @Int)], which results in a roughly even split + -- between positive and negative overflowed Int results, while still + -- producing a fair number of non-overflowing products. + where maxc = toInteger (maxBound @Int) * 5 `quot` max 5 (abs $ toInteger x) + +prop_checkedMultiply = forAll genScale $ \scale -> + forAll (genVal scale) $ \x -> + forAll (multCompl x) $ \y -> if oflo x y + then expectSizeOverflow (P.checkedMultiply "" x y) + else property $ P.checkedMultiply "" x y == x * y + where genScale = choose (0, finiteBitSize @Int 0 - 1) + genVal scale = choose (0, bit scale - 1) + oflo x y = toInteger x * toInteger y /= toInteger @Int (x * y) + +prop_stimesOverflowBasic bs = forAll (multCompl len) $ \n -> + toInteger n * toInteger len > maxInt ==> expectSizeOverflow (stimes n bs) + where + maxInt = toInteger @Int (maxBound @Int) + len = P.length bs + +prop_stimesOverflowScary bs = + -- "Scary" because this test will cause heap corruption + -- (not just memory exhaustion) with the old stimes implementation. + n > 1 ==> expectSizeOverflow (stimes reps bs) + where + n = P.length bs + reps = maxBound @Word `quot` fromIntegral @Int @Word n + 1 + +prop_stimesOverflowEmpty = forAll (choose (0, maxBound @Word)) $ \n -> + stimes n mempty === mempty @P.ByteString + +concat32bitOverflow :: (Int -> a) -> ([a] -> a) -> Property +concat32bitOverflow replicateLike concatLike = let + intBits = finiteBitSize @Int 0 + largeBS = concatLike $ replicate (bit 14) $ replicateLike (bit 17) + in if intBits /= 32 + then label "skipped due to non-32-bit Int" True + else expectSizeOverflow largeBS + +prop_32bitOverflow_Strict_mconcat :: Property +prop_32bitOverflow_Strict_mconcat = + concat32bitOverflow (`P.replicate` 0) mconcat + +prop_32bitOverflow_Lazy_toStrict :: Property +prop_32bitOverflow_Lazy_toStrict = + concat32bitOverflow (`P.replicate` 0) (L.toStrict . L.fromChunks) + +prop_32bitOverflow_Short_mconcat :: Property +prop_32bitOverflow_Short_mconcat = + concat32bitOverflow makeShort mconcat + where makeShort n = Short.toShort $ P.replicate n 0 + + +------------------------------------------------------------------------ + +prop_packUptoLenBytes cs = + forAll (choose (0, length cs + 1)) $ \n -> + let (bs, cs') = P.packUptoLenBytes n cs + in P.length bs == min n (length cs) + && take n cs == P.unpack bs + && P.pack (take n cs) == bs + && drop n cs == cs' + +prop_packUptoLenChars (String8 cs) = + forAll (choose (0, length cs + 1)) $ \n -> + let (bs, cs') = P.packUptoLenChars n cs + in P.length bs == min n (length cs) + && take n cs == C.unpack bs + && C.pack (take n cs) == bs + && drop n cs == cs' + +prop_unpackAppendBytesLazy cs' = + forAll (sized $ \n -> resize (n * 10) arbitrary) $ \cs -> + forAll (choose (0, 2)) $ \n -> + P.unpackAppendBytesLazy (P.drop n $ P.pack cs) cs' == drop n cs ++ cs' +prop_unpackAppendCharsLazy (String8 cs') = + forAll (sized $ \n -> resize (n * 10) arbitrary) $ \(String8 cs) -> + forAll (choose (0, 2)) $ \n -> + P.unpackAppendCharsLazy (P.drop n $ C.pack cs) cs' == drop n cs ++ cs' + +prop_unpackAppendBytesStrict cs cs' = + forAll (choose (0, length cs)) $ \n -> + P.unpackAppendBytesStrict (P.drop n $ P.pack cs) cs' == drop n cs ++ cs' + +prop_unpackAppendCharsStrict (String8 cs) (String8 cs') = + forAll (choose (0, length cs)) $ \n -> + P.unpackAppendCharsStrict (P.drop n $ C.pack cs) cs' == drop n cs ++ cs' + +------------------------------------------------------------------------ +-- Unsafe functions + +-- Test unsafePackAddress +prop_unsafePackAddress (CByteString x) = ioProperty $ do + let (p,_,_) = P.toForeignPtr (x `P.snoc` 0) + y <- withForeignPtr p $ \(Ptr addr) -> + P.unsafePackAddress addr + return (y == x) + +-- Test unsafePackAddressLen +prop_unsafePackAddressLen x = ioProperty $ do + let i = P.length x + (p,_,_) = P.toForeignPtr (x `P.snoc` 0) + y <- withForeignPtr p $ \(Ptr addr) -> + P.unsafePackAddressLen i addr + return (y == x) + +prop_unsafeUseAsCString x = ioProperty $ do + let n = P.length x + y <- P.unsafeUseAsCString x $ \cstr -> + sequence [ do a <- peekElemOff cstr i + let b = x `P.index` i + return (a == fromIntegral b) + | i <- [0.. n-1] ] + return (and y) + +prop_unsafeUseAsCStringLen x = ioProperty $ do + let n = P.length x + y <- P.unsafeUseAsCStringLen x $ \(cstr,_) -> + sequence [ do a <- peekElemOff cstr i + let b = x `P.index` i + return (a == fromIntegral b) + | i <- [0.. n-1] ] + return (and y) + +prop_useAsCString x = ioProperty $ do + let n = P.length x + y <- P.useAsCString x $ \cstr -> + sequence [ do a <- peekElemOff cstr i + let b = x `P.index` i + return (a == fromIntegral b) + | i <- [0.. n-1] ] + return (and y) + +prop_packCString (CByteString x) = ioProperty $ do + y <- P.useAsCString x $ P.unsafePackCString + return (y == x) + +prop_packCString_safe (CByteString x) = ioProperty $ do + y <- P.useAsCString x $ P.packCString + return (y == x) + +prop_packCStringLen x = ioProperty $ do + y <- P.useAsCStringLen x $ P.unsafePackCStringLen + return (y == x && P.length y == P.length x) + +prop_packCStringLen_safe x = ioProperty $ do + y <- P.useAsCStringLen x $ P.packCStringLen + return (y == x && P.length y == P.length x) + +prop_packMallocCString (CByteString x) = ioProperty $ do + + let (fp,_,_) = P.toForeignPtr x + ptr <- mallocArray0 (P.length x) :: IO (Ptr Word8) + forM_ [0 .. P.length x] $ \n -> pokeElemOff ptr n 0 + withForeignPtr fp $ \qtr -> copyArray ptr qtr (P.length x) + y <- P.unsafePackMallocCString (castPtr ptr) + + let !z = y == x + free ptr `seq` return z + +prop_unsafeFinalize x = + P.length x > 0 ==> + ioProperty $ do + x <- P.unsafeFinalize x + return (x == ()) + +prop_packCStringFinaliser x = ioProperty $ do + y <- P.useAsCString x $ \cstr -> P.unsafePackCStringFinalizer (castPtr cstr) (P.length x) (return ()) + return (y == x) + +prop_fromForeignPtr x = (let (a,b,c) = (P.toForeignPtr x) + in P.fromForeignPtr a b c) == x + +------------------------------------------------------------------------ +-- IO + +prop_read_write_file_P x = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + P.writeFile fn x + y <- P.readFile fn + removeFile fn + return (x === y) + +prop_read_write_file_C x = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + C.writeFile fn x + y <- C.readFile fn + removeFile fn + return (x === y) + +prop_read_write_file_L x = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + L.writeFile fn x + y <- L.readFile fn + L.length y `seq` removeFile fn + return (x === y) + +prop_read_write_file_D x = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + D.writeFile fn x + y <- D.readFile fn + D.length y `seq` removeFile fn + return (x === y) + +------------------------------------------------------------------------ + +prop_append_file_P x y = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + P.writeFile fn x + P.appendFile fn y + z <- P.readFile fn + removeFile fn + return (z === x `P.append` y) + +prop_append_file_C x y = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + C.writeFile fn x + C.appendFile fn y + z <- C.readFile fn + removeFile fn + return (z === x `C.append` y) + +prop_append_file_L x y = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + L.writeFile fn x + L.appendFile fn y + z <- L.readFile fn + L.length y `seq` removeFile fn + return (z === x `L.append` y) + +prop_append_file_D x y = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + D.writeFile fn x + D.appendFile fn y + z <- D.readFile fn + D.length y `seq` removeFile fn + return (z === x `D.append` y) + +prop_packAddress = C.pack "this is a test" + == + C.pack "this is a test" + +prop_isSpaceWord8 w = isSpace c == P.isSpaceChar8 c + where c = chr (fromIntegral (w :: Word8)) + + +------------------------------------------------------------------------ +-- ByteString.Short +-- + +prop_short_pack_unpack xs = + (Short.unpack . Short.pack) xs == xs +prop_short_toShort_fromShort bs = + (Short.fromShort . Short.toShort) bs == bs + +prop_short_toShort_unpack bs = + (Short.unpack . Short.toShort) bs == P.unpack bs +prop_short_pack_fromShort xs = + (Short.fromShort . Short.pack) xs == P.pack xs + +prop_short_empty = + Short.empty == Short.toShort P.empty + && Short.empty == Short.pack [] + && Short.null (Short.toShort P.empty) + && Short.null (Short.pack []) + && Short.null Short.empty + +prop_short_null_toShort bs = + P.null bs == Short.null (Short.toShort bs) +prop_short_null_pack xs = + null xs == Short.null (Short.pack xs) + +prop_short_length_toShort bs = + P.length bs == Short.length (Short.toShort bs) +prop_short_length_pack xs = + length xs == Short.length (Short.pack xs) + +prop_short_index_pack xs = + all (\i -> Short.pack xs `Short.index` i == xs !! i) + [0 .. length xs - 1] +prop_short_index_toShort bs = + all (\i -> Short.toShort bs `Short.index` i == bs `P.index` i) + [0 .. P.length bs - 1] + +prop_short_eq xs ys = + (xs == ys) == (Short.pack xs == Short.pack ys) +prop_short_ord xs ys = + (xs `compare` ys) == (Short.pack xs `compare` Short.pack ys) + +prop_short_mappend_empty_empty = + Short.empty `mappend` Short.empty == Short.empty +prop_short_mappend_empty xs = + Short.empty `mappend` Short.pack xs == Short.pack xs + && Short.pack xs `mappend` Short.empty == Short.pack xs +prop_short_mappend xs ys = + (xs `mappend` ys) == Short.unpack (Short.pack xs `mappend` Short.pack ys) +prop_short_mconcat xss = + mconcat xss == Short.unpack (mconcat (map Short.pack xss)) + +prop_short_fromString s = + fromString s == Short.fromShort (fromString s) + +prop_short_show xs = + show (Short.pack xs) == show (map P.w2c xs) +prop_short_show' xs = + show (Short.pack xs) == show (P.pack xs) + +prop_short_read xs = + read (show (Short.pack xs)) == Short.pack xs + +prop_short_pinned :: NonNegative Int -> Property +prop_short_pinned (NonNegative (I# len#)) = runST $ ST $ \s -> + case newPinnedByteArray# len# s of + (# s', mba# #) -> case unsafeFreezeByteArray# mba# s' of + (# s'', ba# #) -> let sbs = Short.SBS ba# in + (# s'', sbs === Short.toShort (Short.fromShort sbs) #) + +short_tests = + [ testProperty "pack/unpack" prop_short_pack_unpack + , testProperty "toShort/fromShort" prop_short_toShort_fromShort + , testProperty "toShort/unpack" prop_short_toShort_unpack + , testProperty "pack/fromShort" prop_short_pack_fromShort + , testProperty "empty" prop_short_empty + , testProperty "null/toShort" prop_short_null_toShort + , testProperty "null/pack" prop_short_null_pack + , testProperty "length/toShort" prop_short_length_toShort + , testProperty "length/pack" prop_short_length_pack + , testProperty "index/pack" prop_short_index_pack + , testProperty "index/toShort" prop_short_index_toShort + , testProperty "Eq" prop_short_eq + , testProperty "Ord" prop_short_ord + , testProperty "mappend/empty/empty" prop_short_mappend_empty_empty + , testProperty "mappend/empty" prop_short_mappend_empty + , testProperty "mappend" prop_short_mappend + , testProperty "mconcat" prop_short_mconcat + , testProperty "fromString" prop_short_fromString + , testProperty "show" prop_short_show + , testProperty "show'" prop_short_show' + , testProperty "read" prop_short_read + , testProperty "pinned" prop_short_pinned + ] + +------------------------------------------------------------------------ +-- Strictness checks. + +explosiveTail :: L.ByteString -> L.ByteString +explosiveTail = (`L.append` error "Tail of this byte string is undefined!") + +------------------------------------------------------------------------ +-- The entry point + +testSuite :: TestTree +testSuite = testGroup "Properties" + [ testGroup "ShortByteString" PropSBS.tests + , testGroup "StrictWord8" PropBS.tests + , testGroup "StrictChar8" PropBS8.tests + , testGroup "LazyWord8" PropBL.tests + , testGroup "LazyChar8" PropBL8.tests + , testGroup "Overflow" overflow_tests + , testGroup "Misc" misc_tests + , testGroup "IO" io_tests + , testGroup "Short" short_tests + , testGroup "Strictness" strictness_checks + ] + +io_tests = + [ testProperty "readFile.writeFile" prop_read_write_file_P + , testProperty "readFile.writeFile" prop_read_write_file_C + , testProperty "readFile.writeFile" prop_read_write_file_L + , testProperty "readFile.writeFile" prop_read_write_file_D + + , testProperty "appendFile " prop_append_file_P + , testProperty "appendFile " prop_append_file_C + , testProperty "appendFile " prop_append_file_L + , testProperty "appendFile " prop_append_file_D + + , testProperty "packAddress " prop_packAddress + ] + +overflow_tests = + [ testProperty "checkedAdd" prop_checkedAdd + , testProperty "checkedMultiply" prop_checkedMultiply + , testProperty "StrictByteString stimes (basic)" prop_stimesOverflowBasic + , testProperty "StrictByteString stimes (scary)" prop_stimesOverflowScary + , testProperty "StrictByteString stimes (empty)" prop_stimesOverflowEmpty + , testProperty "StrictByteString mconcat" prop_32bitOverflow_Strict_mconcat + , testProperty "LazyByteString toStrict" prop_32bitOverflow_Lazy_toStrict + , testProperty "ShortByteString mconcat" prop_32bitOverflow_Short_mconcat + ] + +misc_tests = + [ testProperty "packUptoLenBytes" prop_packUptoLenBytes + , testProperty "packUptoLenChars" prop_packUptoLenChars + , testProperty "unpackAppendBytesLazy" prop_unpackAppendBytesLazy + , testProperty "unpackAppendCharsLazy" prop_unpackAppendCharsLazy + , testProperty "unpackAppendBytesStrict"prop_unpackAppendBytesStrict + , testProperty "unpackAppendCharsStrict"prop_unpackAppendCharsStrict + + , testProperty "unsafe pack address" prop_unsafePackAddress + , testProperty "unsafe pack address len"prop_unsafePackAddressLen + , testProperty "unsafeUseAsCString" prop_unsafeUseAsCString + , testProperty "unsafeUseAsCStringLen" prop_unsafeUseAsCStringLen + , testProperty "useAsCString" prop_useAsCString + , testProperty "packCString" prop_packCString + , testProperty "packCString safe" prop_packCString_safe + , testProperty "packCStringLen" prop_packCStringLen + , testProperty "packCStringLen safe" prop_packCStringLen_safe + , testProperty "packCStringFinaliser" prop_packCStringFinaliser + , testProperty "packMallocString" prop_packMallocCString + , testProperty "unsafeFinalise" prop_unsafeFinalize + , testProperty "fromForeignPtr" prop_fromForeignPtr + + , testProperty "w2c . c2w" prop_bijectionBB + , testProperty "c2w . w2c" prop_bijectionBB' + + , testProperty "unsafeHead" prop_unsafeHead + , testProperty "unsafeTail" prop_unsafeTail + , testProperty "unsafeLast" prop_unsafeLast + , testProperty "unsafeInit" prop_unsafeInit + , testProperty "unsafeIndex" prop_unsafeIndexBB + + , testProperty "lines_lazy" prop_lines_lazy + , testProperty "lines_lazy2" prop_lines_lazy2 + , testProperty "lines_lazy3" prop_lines_lazy3 + , testProperty "lines_invar" prop_lines_empty_invariant + , testProperty "strip" prop_strip + , testProperty "isSpace" prop_isSpaceWord8 + + , testProperty "readWordSafe" prop_readWordSafe + , testProperty "readWordUnsafe" prop_readWordUnsafe + , testProperty "readIntBoundsCC" prop_readIntBoundsCC + , testProperty "readIntBoundsLC" prop_readIntBoundsLC + , testProperty "readIntegerSafe" prop_readIntegerSafe + , testProperty "readIntegerUnsafe" prop_readIntegerUnsafe + , testProperty "readNaturalSafe" prop_readNaturalSafe + , testProperty "readNaturalUnsafe" prop_readNaturalUnsafe + ] + +strictness_checks = + [ testGroup "Lazy Word8" + [ testProperty "foldr is lazy" $ \ xs -> + List.genericTake (L.length xs) (L.foldr (:) [ ] (explosiveTail xs)) === L.unpack xs + , testProperty "foldr' is strict" $ expectFailure $ \ xs ys -> + List.genericTake (L.length xs) (L.foldr' (:) [ ] (explosiveTail (xs <> ys))) === L.unpack xs + , testProperty "foldr1 is lazy" $ \ xs -> L.length xs > 0 ==> + L.foldr1 const (explosiveTail (xs <> L.singleton 1)) === L.head xs + , testProperty "foldr1' is strict" $ expectFailure $ \ xs ys -> L.length xs > 0 ==> + L.foldr1' const (explosiveTail (xs <> L.singleton 1 <> ys)) === L.head xs + , testProperty "scanl is lazy" $ \ xs -> + L.take (L.length xs + 1) (L.scanl (+) 0 (explosiveTail (xs <> L.singleton 1))) === (L.pack . fmap (L.foldr (+) 0) . L.inits) xs + , testProperty "scanl1 is lazy" $ \ xs -> L.length xs > 0 ==> + L.take (L.length xs) (L.scanl1 (+) (explosiveTail (xs <> L.singleton 1))) === (L.pack . fmap (L.foldr1 (+)) . drop 1 . L.inits) xs + ] + , testGroup "Lazy Char" + [ testProperty "foldr is lazy" $ \ xs -> + List.genericTake (D.length xs) (D.foldr (:) [ ] (explosiveTail xs)) === D.unpack xs + , testProperty "foldr' is strict" $ expectFailure $ \ xs ys -> + List.genericTake (D.length xs) (D.foldr' (:) [ ] (explosiveTail (xs <> ys))) === D.unpack xs + , testProperty "foldr1 is lazy" $ \ xs -> D.length xs > 0 ==> + D.foldr1 const (explosiveTail (xs <> D.singleton 'x')) === D.head xs + , testProperty "foldr1' is strict" $ expectFailure $ \ xs ys -> D.length xs > 0 ==> + D.foldr1' const (explosiveTail (xs <> D.singleton 'x' <> ys)) === D.head xs + , testProperty "scanl is lazy" $ \ xs -> let char1 +. char2 = toEnum (fromEnum char1 + fromEnum char2) in + D.take (D.length xs + 1) (D.scanl (+.) '\NUL' (explosiveTail (xs <> D.singleton '\SOH'))) === (D.pack . fmap (D.foldr (+.) '\NUL') . D.inits) xs + , testProperty "scanl1 is lazy" $ \ xs -> D.length xs > 0 ==> let char1 +. char2 = toEnum (fromEnum char1 + fromEnum char2) in + D.take (D.length xs) (D.scanl1 (+.) (explosiveTail (xs <> D.singleton '\SOH'))) === (D.pack . fmap (D.foldr1 (+.)) . drop 1 . D.inits) xs + , testProperty "unlines is lazy" $ \ xs -> D.take (D.length xs + 1) (D.unlines (xs : error "Tail of this list is undefined!")) === xs `D.snoc` '\n' + ] + ] + +removeFile :: String -> IO () +removeFile fn = void $ withCString fn c_unlink diff --git a/tests/Properties/ByteString.hs b/tests/Properties/ByteString.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ByteString.hs @@ -0,0 +1,830 @@ +-- | +-- Module : Properties.ByteString +-- Copyright : (c) Andrew Lelechenko 2021 +-- License : BSD-style + +{-# LANGUAGE CPP #-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ViewPatterns #-} +-- We need @AllowAmbiguousTypes@ in order to be able to use @TypeApplications@ +-- to disambiguate the desired instance of class methods whose instance cannot +-- be inferred from the caller's context. We would otherwise have to use +-- proxy arguments. Here the 'RdInt' class methods used to generate tests for +-- all the various 'readInt' types require explicit type applications. + +-- We are happy to sacrifice optimizations in exchange for faster compilation, +-- but need to test rewrite rules. As one can check using -ddump-rule-firings, +-- rewrite rules do not fire in -O0 mode, so we use -O1, but disable almost all +-- optimizations. It roughly halves compilation time. +{-# OPTIONS_GHC -O1 -fenable-rewrite-rules + -fmax-simplifier-iterations=1 -fsimplifier-phases=0 + -fno-call-arity -fno-case-merge -fno-cmm-elim-common-blocks -fno-cmm-sink + -fno-cpr-anal -fno-cse -fno-do-eta-reduction -fno-float-in -fno-full-laziness + -fno-loopification -fno-specialise -fno-strictness #-} + +-- BYTESTRING_CHAR8 and BYTESTRING_LAZY are defined in +-- Properties.ByteString{Char8,Lazy,LazyChar8}, which include this file. +#ifndef BYTESTRING_CHAR8 + +#if defined(BYTESTRING_SHORT) +module Properties.ShortByteString (tests) where +import qualified Data.ByteString.Short as B +import qualified Data.ByteString.Short.Internal as B +#define BYTESTRING_TYPE B.ShortByteString +#elif !(defined BYTESTRING_LAZY) +module Properties.ByteString (tests) where +#define BYTESTRING_TYPE B.ByteString +import qualified Data.ByteString as B +import GHC.IO.Encoding +#else +module Properties.ByteStringLazy (tests) where +#define BYTESTRING_TYPE B.ByteString +import qualified Data.ByteString.Lazy as B +#endif + +#else + +#ifndef BYTESTRING_LAZY +module Properties.ByteStringChar8 (tests) where +import qualified Data.ByteString.Char8 as B +#define BYTESTRING_TYPE B.ByteString +#else +module Properties.ByteStringLazyChar8 (tests) where +import qualified Data.ByteString.Lazy.Char8 as B +#define BYTESTRING_TYPE B.ByteString +#endif + +import Data.Int +import Numeric.Natural (Natural) + +import Text.Read + +#endif + +import Prelude hiding (head, tail) +import Control.Arrow +import Data.Char +import Data.Data (toConstr, showConstr, Data) +import Data.Foldable +import Data.Generics.Text (gread, gshow) +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE +import Data.Semigroup +import Data.String +import Data.Tuple +import Data.Word +import Test.Tasty +import Test.Tasty.QuickCheck +import QuickCheckUtils + +#ifdef BYTESTRING_LAZY +import Data.Int +#endif + +#ifndef BYTESTRING_CHAR8 +toElem :: Word8 -> Word8 +toElem = id +#else +toElem :: Char8 -> Char +toElem (Char8 c) = c + +class (Integral a, Show a) => RdInt a where + bread :: BYTESTRING_TYPE -> Maybe (a, BYTESTRING_TYPE) + sread :: String -> Maybe (a, String) + +instance RdInt Int where { bread = B.readInt; sread = readInt } +instance RdInt Int8 where { bread = B.readInt8; sread = readInt8 } +instance RdInt Int16 where { bread = B.readInt16; sread = readInt16 } +instance RdInt Int32 where { bread = B.readInt32; sread = readInt32 } +instance RdInt Int64 where { bread = B.readInt64; sread = readInt64 } +-- +instance RdInt Word where { bread = B.readWord; sread = readWord } +instance RdInt Word8 where { bread = B.readWord8; sread = readWord8 } +instance RdInt Word16 where { bread = B.readWord16; sread = readWord16 } +instance RdInt Word32 where { bread = B.readWord32; sread = readWord32 } +instance RdInt Word64 where { bread = B.readWord64; sread = readWord64 } +-- +instance RdInt Integer where { bread = B.readInteger; sread = readInteger } +instance RdInt Natural where { bread = B.readNatural; sread = readNatural } + +instance Arbitrary Natural where + arbitrary = i2n <$> arbitrary + where i2n :: Integer -> Natural + i2n i | i >= 0 = fromIntegral i + | otherwise = fromIntegral $ negate i + +testRdInt :: forall a. (Arbitrary a, RdInt a) => String -> TestTree +testRdInt s = testGroup s $ + [ testProperty "from string" $ int64OK $ \value prefix suffix -> + let si = show @a value + b = prefix <> B.pack si <> suffix + in fmap (second B.unpack) (bread @a b) + === sread @a (B.unpack prefix ++ si ++ B.unpack suffix) + , testProperty "from number" $ int64OK $ \n -> + bread @a (B.pack (show n)) === Just (n, B.empty) + ] +#endif + +intToIndexTy :: Int -> IndexTy +#ifdef BYTESTRING_LAZY +type IndexTy = Int64 +intToIndexTy = fromIntegral @Int @Int64 +#else +type IndexTy = Int +intToIndexTy = id +#endif + +tests :: [TestTree] +tests = + [ testProperty "pack . unpack" $ + \x -> x === B.pack (B.unpack x) + , testProperty "unpack . pack" $ + \(map toElem -> xs) -> xs === B.unpack (B.pack xs) + , testProperty "read . show" $ + \x -> (x :: BYTESTRING_TYPE) === read (show x) +#ifndef BYTESTRING_SHORT + , testProperty "fromStrict . toStrict" $ + \x -> B.fromStrict (B.toStrict x) === x + , testProperty "toStrict . fromStrict" $ + \x -> B.toStrict (B.fromStrict x) === x +#endif +#if !defined(BYTESTRING_LAZY) && !defined(BYTESTRING_CHAR8) && !defined(BYTESTRING_SHORT) + , testProperty "toFilePath >>= fromFilePath" $ + \x -> ioProperty $ do + r <- B.toFilePath x >>= B.fromFilePath + pure (r === x) + , testProperty "fromFilePath >>= toFilePath" $ ioProperty $ do + let prop x = ioProperty $ do + r <- B.fromFilePath x >>= B.toFilePath + pure (r === x) + -- Normally getFileSystemEncoding returns a Unicode encoding, + -- but if it is ASCII, we should not generate Unicode filenames. + enc <- getFileSystemEncoding + pure $ case textEncodingName enc of + "ASCII" -> property (prop . getASCIIString) + "ANSI_X3.4-1968" -> property (prop . getASCIIString) + _ -> property prop +#endif + + , testProperty "==" $ + \x y -> (x == y) === (B.unpack x == B.unpack y) + , testProperty "== refl" $ + \x -> (x :: BYTESTRING_TYPE) == x + , testProperty "== symm" $ + \x y -> ((x :: BYTESTRING_TYPE) == y) === (y == x) + , testProperty "== pack unpack" $ + \x -> x == B.pack (B.unpack x) +#ifndef BYTESTRING_SHORT + , testProperty "== copy" $ + \x -> x == B.copy x +#endif + + , testProperty "compare" $ + \x y -> compare x y === compare (B.unpack x) (B.unpack y) + , testProperty "compare EQ" $ + \x -> compare (x :: BYTESTRING_TYPE) x == EQ + , testProperty "compare GT" $ + \x (toElem -> c) -> compare (B.snoc x c) x == GT + , testProperty "compare LT" $ + \x (toElem -> c) -> compare x (B.snoc x c) == LT + , testProperty "compare GT empty" $ + \x -> not (B.null x) ==> compare x B.empty == GT + , testProperty "compare LT empty" $ + \x -> not (B.null x) ==> compare B.empty x == LT + , testProperty "compare GT concat" $ + \x y -> not (B.null y) ==> compare (x <> y) x == GT + , testProperty "compare char" $ + \(toElem -> c) (toElem -> d) -> compare c d == compare (B.singleton c) (B.singleton d) +#ifndef BYTESTRING_CHAR8 + , testProperty "compare unsigned" $ once $ + compare (B.singleton 255) (B.singleton 127) == GT +#endif + + , testProperty "null" $ + \x -> B.null x === null (B.unpack x) + , testProperty "empty 0" $ once $ + B.length B.empty === 0 + , testProperty "empty []" $ once $ + B.unpack B.empty === [] + , testProperty "mempty 0" $ once $ + B.length mempty === 0 + , testProperty "mempty []" $ once $ + B.unpack mempty === [] + + , testProperty "concat" $ + \(Sqrt xs) -> B.unpack (B.concat xs) === concat (map B.unpack xs) + , testProperty "concat [x,x]" $ + \x -> B.unpack (B.concat [x, x]) === concat [B.unpack x, B.unpack x] + , testProperty "concat [x,[]]" $ + \x -> B.unpack (B.concat [x, B.empty]) === concat [B.unpack x, []] + , testProperty "mconcat" $ + \(Sqrt xs) -> B.unpack (mconcat xs) === mconcat (map B.unpack xs) + , testProperty "mconcat [x,x]" $ + \x -> B.unpack (mconcat [x, x]) === mconcat [B.unpack x, B.unpack x] + , testProperty "mconcat [x,[]]" $ + \x -> B.unpack (mconcat [x, B.empty]) === mconcat [B.unpack x, []] + + , testProperty "null" $ + \x -> B.null x === null (B.unpack x) + , testProperty "reverse" $ + \x -> B.unpack (B.reverse x) === reverse (B.unpack x) +#ifndef BYTESTRING_SHORT + , testProperty "transpose" $ + \xs -> map B.unpack (B.transpose xs) === List.transpose (map B.unpack xs) + , testProperty "group" $ + \x -> map B.unpack (B.group x) === List.group (B.unpack x) + , testProperty "groupBy" $ + \f x -> map B.unpack (B.groupBy f x) === List.groupBy f (B.unpack x) + , testProperty "groupBy ==" $ + \x -> map B.unpack (B.groupBy (==) x) === List.groupBy (==) (B.unpack x) + , testProperty "groupBy /=" $ + \x -> map B.unpack (B.groupBy (/=) x) === List.groupBy (/=) (B.unpack x) + , testProperty "inits" $ + \x -> map B.unpack (B.inits x) === List.inits (B.unpack x) + , testProperty "tails" $ + \x -> map B.unpack (B.tails x) === List.tails (B.unpack x) + , testProperty "initsNE" $ + \x -> NE.map B.unpack (B.initsNE x) === NE.inits (B.unpack x) + , testProperty "tailsNE" $ + \x -> NE.map B.unpack (B.tailsNE x) === NE.tails (B.unpack x) +#endif + , testProperty "all" $ + \f x -> B.all f x === all f (B.unpack x) + , testProperty "all ==" $ + \(toElem -> c) x -> B.all (== c) x === all (== c) (B.unpack x) + , testProperty "any" $ + \f x -> B.any f x === any f (B.unpack x) + , testProperty "any ==" $ + \(toElem -> c) x -> B.any (== c) x === any (== c) (B.unpack x) + , testProperty "append" $ + \x y -> B.unpack (B.append x y) === B.unpack x ++ B.unpack y + , testProperty "mappend" $ + \x y -> B.unpack (mappend x y) === B.unpack x `mappend` B.unpack y + , testProperty "<>" $ + \x y -> B.unpack (x <> y) === B.unpack x <> B.unpack y + , testProperty "stimes" $ + \(Sqrt (NonNegative n)) (Sqrt x) -> stimes (n :: Int) (x :: BYTESTRING_TYPE) === stimesMonoid n x + + , testProperty "break" $ + \f x -> (B.unpack *** B.unpack) (B.break f x) === break f (B.unpack x) + , testProperty "break ==" $ + \(toElem -> c) x -> (B.unpack *** B.unpack) (B.break (== c) x) === break (== c) (B.unpack x) + , testProperty "break /=" $ + \(toElem -> c) x -> (B.unpack *** B.unpack) (B.break (/= c) x) === break (/= c) (B.unpack x) + , testProperty "break span" $ + \f x -> B.break f x === B.span (not . f) x + , testProperty "breakEnd" $ + \f x -> B.breakEnd f x === swap ((B.reverse *** B.reverse) (B.break f (B.reverse x))) + , testProperty "breakEnd" $ + \f x -> B.breakEnd f x === B.spanEnd (not . f) x + +#ifndef BYTESTRING_LAZY + , testProperty "break breakSubstring" $ + \(toElem -> c) x -> B.break (== c) x === B.breakSubstring (B.singleton c) x + , testProperty "breakSubstring" $ + \x y -> not (B.null x) ==> B.null (snd (B.breakSubstring x y)) === not (B.isInfixOf x y) + , testProperty "breakSubstring empty" $ + \x -> B.breakSubstring B.empty x === (B.empty, x) +#endif +#ifdef BYTESTRING_CHAR8 + , testProperty "break isSpace" $ + \x -> (B.unpack *** B.unpack) (B.break isSpace x) === break isSpace (B.unpack x) +#endif + +#ifndef BYTESTRING_SHORT + , testProperty "concatMap" $ + \f x -> B.unpack (B.concatMap f x) === concatMap (B.unpack . f) (B.unpack x) + , testProperty "concatMap singleton" $ + \x -> B.unpack (B.concatMap B.singleton x) === concatMap (: []) (B.unpack x) +#endif + + , testProperty "singleton" $ + \(toElem -> c) -> B.unpack (B.singleton c) === [c] + , testProperty "cons" $ + \(toElem -> c) x -> B.unpack (B.cons c x) === c : B.unpack x + , testProperty "cons []" $ + \(toElem -> c) -> B.unpack (B.cons c B.empty) === [c] + , testProperty "uncons" $ + \x -> fmap (second B.unpack) (B.uncons x) === List.uncons (B.unpack x) + , testProperty "snoc" $ + \(toElem -> c) x -> B.unpack (B.snoc x c) === B.unpack x ++ [c] + , testProperty "snoc []" $ + \(toElem -> c) -> B.unpack (B.snoc B.empty c) === [c] + , testProperty "unsnoc" $ + \x -> fmap (first B.unpack) (B.unsnoc x) === unsnoc (B.unpack x) +#ifdef BYTESTRING_LAZY + , testProperty "cons'" $ + \(toElem -> c) x -> B.unpack (B.cons' c x) === c : B.unpack x +#endif + + , testProperty "drop" $ + \(intToIndexTy -> n) x -> B.unpack (B.drop n x) === List.genericDrop n (B.unpack x) + , testProperty "drop 10" $ + \x -> let n = 10 in B.unpack (B.drop n x) === List.genericDrop n (B.unpack x) + , testProperty "drop 2^31" $ + \x -> let n = 2^31 in B.unpack (B.drop n x) === List.genericDrop n (B.unpack x) + , testProperty "dropWhile" $ + \f x -> B.unpack (B.dropWhile f x) === dropWhile f (B.unpack x) + , testProperty "dropWhile ==" $ + \(toElem -> c) x -> B.unpack (B.dropWhile (== c) x) === dropWhile (== c) (B.unpack x) + , testProperty "dropWhile /=" $ + \(toElem -> c) x -> B.unpack (B.dropWhile (/= c) x) === dropWhile (/= c) (B.unpack x) +#ifdef BYTESTRING_CHAR8 + , testProperty "dropWhile isSpace" $ + \x -> B.unpack (B.dropWhile isSpace x) === dropWhile isSpace (B.unpack x) +#endif + + , testProperty "take" $ + \(intToIndexTy -> n) x -> B.unpack (B.take n x) === List.genericTake n (B.unpack x) + , testProperty "take 10" $ + \x -> let n = 10 in B.unpack (B.take n x) === List.genericTake n (B.unpack x) + , testProperty "take 2^31" $ + \x -> let n = 2^31 in B.unpack (B.take n x) === List.genericTake n (B.unpack x) + , testProperty "takeWhile" $ + \f x -> B.unpack (B.takeWhile f x) === takeWhile f (B.unpack x) + , testProperty "takeWhile ==" $ + \(toElem -> c) x -> B.unpack (B.takeWhile (== c) x) === takeWhile (== c) (B.unpack x) + , testProperty "takeWhile /=" $ + \(toElem -> c) x -> B.unpack (B.takeWhile (/= c) x) === takeWhile (/= c) (B.unpack x) +#ifdef BYTESTRING_CHAR8 + , testProperty "takeWhile isSpace" $ + \x -> B.unpack (B.takeWhile isSpace x) === takeWhile isSpace (B.unpack x) +#endif + + , testProperty "dropEnd" $ + \(intToIndexTy -> n) x -> B.dropEnd n x === B.take (B.length x - n) x + , testProperty "dropWhileEnd" $ + \f x -> B.dropWhileEnd f x === B.reverse (B.dropWhile f (B.reverse x)) + , testProperty "takeEnd" $ + \(intToIndexTy -> n) x -> B.takeEnd n x === B.drop (B.length x - n) x + , testProperty "takeWhileEnd" $ + \f x -> B.takeWhileEnd f x === B.reverse (B.takeWhile f (B.reverse x)) + +#ifdef BYTESTRING_LAZY + , testProperty "fromChunks . toChunks" $ + \x -> B.fromChunks (B.toChunks x) === x + , testProperty "toChunks . fromChunks" $ + \xs -> B.toChunks (B.fromChunks xs) === filter (/= mempty) xs + , testProperty "append lazy" $ + \(toElem -> c) -> B.head (B.singleton c <> tooStrictErr) === c + , testProperty "compareLength 1" $ + \x -> B.compareLength x (B.length x) === EQ + , testProperty "compareLength 2" $ + \x (toElem -> c) -> B.compareLength (B.snoc x c) (B.length x) === GT + , testProperty "compareLength 3" $ + \x -> B.compareLength x (B.length x + 1) === LT + , testProperty "compareLength 4" $ + \x (toElem -> c) -> B.compareLength (B.snoc x c <> undefined) (B.length x) === GT + , testProperty "compareLength 5" $ + \x (intToIndexTy -> n) -> B.compareLength x n === compare (B.length x) n + , testProperty "dropEnd lazy" $ + \(toElem -> c) -> B.take 1 (B.dropEnd 1 (B.singleton c <> B.singleton c <> B.singleton c <> tooStrictErr)) === B.singleton c + , testProperty "dropWhileEnd lazy" $ + \(toElem -> c) -> B.take 1 (B.dropWhileEnd (const False) (B.singleton c <> tooStrictErr)) === B.singleton c + , testProperty "breakEnd lazy" $ + \(toElem -> c) -> B.take 1 (fst $ B.breakEnd (const True) (B.singleton c <> tooStrictErr)) === B.singleton c + , testProperty "spanEnd lazy" $ + \(toElem -> c) -> B.take 1 (fst $ B.spanEnd (const False) (B.singleton c <> tooStrictErr)) === B.singleton c +#endif + + , testProperty "length" $ + \x -> B.length x === fromIntegral (length (B.unpack x)) + , testProperty "count" $ + \(toElem -> c) x -> B.count c x === fromIntegral (length (List.elemIndices c (B.unpack x))) + -- for long strings, the multiplier is non-round (and not power of 2) + -- to ensure non-trivial prefix or suffix of the string is handled outside any possible SIMD-based loop, + -- which typically handles chunks of 16 or 32 or 64 etc bytes. + , testProperty "count (long strings)" $ + \(toElem -> c) x (Positive n) -> B.count c x * fromIntegral n === B.count c (B.concat $ replicate n x) + , testProperty "filter" $ + \f x -> B.unpack (B.filter f x) === filter f (B.unpack x) + , testProperty "filter compose" $ + \f g x -> B.filter f (B.filter g x) === B.filter (\c -> f c && g c) x + , testProperty "filter ==" $ + \(toElem -> c) x -> B.unpack (B.filter (== c) x) === filter (== c) (B.unpack x) + , testProperty "filter /=" $ + \(toElem -> c) x -> B.unpack (B.filter (/= c) x) === filter (/= c) (B.unpack x) + , testProperty "partition" $ + \f x -> (B.unpack *** B.unpack) (B.partition f x) === List.partition f (B.unpack x) + + , testProperty "find" $ + \f x -> B.find f x === find f (B.unpack x) + , testProperty "findIndex" $ + \f x -> B.findIndex f x === fmap fromIntegral (List.findIndex f (B.unpack x)) +#ifndef BYTESTRING_SHORT + , testProperty "findIndexEnd" $ + \f x -> B.findIndexEnd f x === fmap fromIntegral (findIndexEnd f (B.unpack x)) +#endif + , testProperty "findIndices" $ + \f x -> B.findIndices f x === fmap fromIntegral (List.findIndices f (B.unpack x)) + , testProperty "findIndices ==" $ + \(toElem -> c) x -> B.findIndices (== c) x === fmap fromIntegral (List.findIndices (== c) (B.unpack x)) + + , testProperty "elem" $ + \(toElem -> c) x -> B.elem c x === elem c (B.unpack x) +#ifndef BYTESTRING_SHORT + , testProperty "notElem" $ + \(toElem -> c) x -> B.notElem c x === notElem c (B.unpack x) +#endif + , testProperty "elemIndex" $ + \(toElem -> c) x -> B.elemIndex c x === fmap fromIntegral (List.elemIndex c (B.unpack x)) +#ifndef BYTESTRING_SHORT + , testProperty "elemIndexEnd" $ + \(toElem -> c) x -> B.elemIndexEnd c x === fmap fromIntegral (elemIndexEnd c (B.unpack x)) +#endif + , testProperty "elemIndices" $ + \(toElem -> c) x -> B.elemIndices c x === fmap fromIntegral (List.elemIndices c (B.unpack x)) + + , testProperty "isPrefixOf" $ + \x y -> B.isPrefixOf x y === List.isPrefixOf (B.unpack x) (B.unpack y) + , testProperty "stripPrefix" $ + \x y -> fmap B.unpack (B.stripPrefix x y) === List.stripPrefix (B.unpack x) (B.unpack y) + , testProperty "isSuffixOf" $ + \x y -> B.isSuffixOf x y === List.isSuffixOf (B.unpack x) (B.unpack y) + , testProperty "stripSuffix" $ + \x y -> fmap B.unpack (B.stripSuffix x y) === stripSuffix (B.unpack x) (B.unpack y) +#ifndef BYTESTRING_LAZY + , testProperty "isInfixOf" $ + \x y -> B.isInfixOf x y === List.isInfixOf (B.unpack x) (B.unpack y) +#endif + + , testProperty "map" $ + \f x -> B.unpack (B.map (toElem . f) x) === map (toElem . f) (B.unpack x) + , testProperty "map compose" $ + \f g x -> B.map (toElem . f) (B.map (toElem . g) x) === B.map (toElem . f . toElem . g) x + , testProperty "replicate" $ + \n (toElem -> c) -> B.unpack (B.replicate (fromIntegral n) c) === replicate n c + , testProperty "replicate 0" $ + \(toElem -> c) -> B.unpack (B.replicate 0 c) === replicate 0 c + + , testProperty "span" $ + \f x -> (B.unpack *** B.unpack) (B.span f x) === span f (B.unpack x) + , testProperty "span ==" $ + \(toElem -> c) x -> (B.unpack *** B.unpack) (B.span (== c) x) === span (== c) (B.unpack x) + , testProperty "span /=" $ + \(toElem -> c) x -> (B.unpack *** B.unpack) (B.span (/= c) x) === span (/= c) (B.unpack x) + , testProperty "spanEnd" $ + \f x -> B.spanEnd f x === swap ((B.reverse *** B.reverse) (B.span f (B.reverse x))) + , testProperty "split" $ + \(toElem -> c) x -> map B.unpack (B.split c x) === split c (B.unpack x) + , testProperty "split empty" $ + \(toElem -> c) -> B.split c B.empty === [] + , testProperty "splitWith" $ + \f x -> map B.unpack (B.splitWith f x) === splitWith f (B.unpack x) + , testProperty "splitWith split" $ + \(toElem -> c) x -> B.splitWith (== c) x === B.split c x + , testProperty "splitWith empty" $ + \f -> B.splitWith f B.empty === [] + , testProperty "splitWith length" $ + \f x -> let splits = B.splitWith f x; l1 = fromIntegral (length splits); l2 = B.length (B.filter f x) in + (l1 == l2 || l1 == l2 + 1) && sum (map B.length splits) + l2 == B.length x + + , testProperty "splitAt" $ + \(intToIndexTy -> n) x -> (B.unpack *** B.unpack) (B.splitAt n x) + === List.genericSplitAt n (B.unpack x) + , testProperty "splitAt 10" $ + \x -> let n = 10 in (B.unpack *** B.unpack) (B.splitAt n x) === List.genericSplitAt n (B.unpack x) + , testProperty "splitAt (2^31)" $ + \x -> let n = 2^31 in (B.unpack *** B.unpack) (B.splitAt n x) === List.genericSplitAt n (B.unpack x) + + , testProperty "head" $ + \x -> case B.unpack x of + [] -> property True + hd : _ -> B.head x === hd + , testProperty "last" $ + \x -> not (B.null x) ==> B.last x === last (B.unpack x) + , testProperty "tail" $ + \x -> case B.unpack x of + [] -> property True + _ : tl -> B.unpack (B.tail x) === tl + , testProperty "tail length" $ + \x -> not (B.null x) ==> B.length x === 1 + B.length (B.tail x) + , testProperty "init" $ + \x -> not (B.null x) ==> B.unpack (B.init x) === init (B.unpack x) + , testProperty "init length" $ + \x -> not (B.null x) ==> B.length x === 1 + B.length (B.init x) +#ifndef BYTESTRING_SHORT + , testProperty "maximum" $ + \x -> not (B.null x) ==> B.maximum x === maximum (B.unpack x) + , testProperty "minimum" $ + \x -> not (B.null x) ==> B.minimum x === minimum (B.unpack x) +#endif + + , testProperty "foldl" $ + \f (toElem -> c) x -> B.foldl ((toElem .) . f) c x === foldl ((toElem .) . f) c (B.unpack x) + , testProperty "foldl'" $ + \f (toElem -> c) x -> B.foldl' ((toElem .) . f) c x === foldl' ((toElem .) . f) c (B.unpack x) + , testProperty "foldr" $ + \f (toElem -> c) x -> B.foldr ((toElem .) . f) c x === foldr ((toElem .) . f) c (B.unpack x) + , testProperty "foldr'" $ + \f (toElem -> c) x -> B.foldr' ((toElem .) . f) c x === foldr' ((toElem .) . f) c (B.unpack x) + + , testProperty "foldl cons" $ + \x -> B.foldl (flip B.cons) B.empty x === B.reverse x + , testProperty "foldr cons" $ + \x -> B.foldr B.cons B.empty x === x + , testProperty "foldl special" $ + \(Sqrt x) (toElem -> c) -> B.unpack (B.foldl (\acc t -> if t == c then acc else B.cons t acc) B.empty x) === + foldl (\acc t -> if t == c then acc else t : acc) [] (B.unpack x) + , testProperty "foldr special" $ + \(Sqrt x) (toElem -> c) -> B.unpack (B.foldr (\t acc -> if t == c then acc else B.cons t acc) B.empty x) === + foldr (\t acc -> if t == c then acc else t : acc) [] (B.unpack x) + + , testProperty "foldl1" $ + \f x -> not (B.null x) ==> B.foldl1 ((toElem .) . f) x === foldl1 ((toElem .) . f) (B.unpack x) + , testProperty "foldl1'" $ + \f x -> not (B.null x) ==> B.foldl1' ((toElem .) . f) x === List.foldl1' ((toElem .) . f) (B.unpack x) + , testProperty "foldr1" $ + \f x -> not (B.null x) ==> B.foldr1 ((toElem .) . f) x === foldr1 ((toElem .) . f) (B.unpack x) + , testProperty "foldr1'" $ -- there is not Data.List.foldr1' + \f x -> not (B.null x) ==> B.foldr1' ((toElem .) . f) x === foldr1 ((toElem .) . f) (B.unpack x) + + , testProperty "foldl1 const" $ + \x -> not (B.null x) ==> B.foldl1 const x === B.head x + , testProperty "foldl1 flip const" $ + \x -> not (B.null x) ==> B.foldl1 (flip const) x === B.last x + , testProperty "foldr1 const" $ + \x -> not (B.null x) ==> B.foldr1 const x === B.head x + , testProperty "foldr1 flip const" $ + \x -> not (B.null x) ==> B.foldr1 (flip const) x === B.last x + , testProperty "foldl1 max" $ + \x -> not (B.null x) ==> B.foldl1 max x === B.foldl max minBound x + , testProperty "foldr1 max" $ + \x -> not (B.null x) ==> B.foldr1 max x === B.foldr max minBound x + +#ifndef BYTESTRING_SHORT + , testProperty "scanl" $ + \f (toElem -> c) x -> B.unpack (B.scanl ((toElem .) . f) c x) === scanl ((toElem .) . f) c (B.unpack x) + , testProperty "scanl foldl" $ + \f (toElem -> c) x -> not (B.null x) ==> B.last (B.scanl ((toElem .) . f) c x) === B.foldl ((toElem .) . f) c x + + , testProperty "scanr" $ + \f (toElem -> c) x -> B.unpack (B.scanr ((toElem .) . f) c x) === scanr ((toElem .) . f) c (B.unpack x) + , testProperty "scanl1" $ + \f x -> B.unpack (B.scanl1 ((toElem .) . f) x) === scanl1 ((toElem .) . f) (B.unpack x) + , testProperty "scanl1 empty" $ + \f -> B.scanl1 f B.empty === B.empty + , testProperty "scanr1" $ + \f x -> B.unpack (B.scanr1 ((toElem .) . f) x) === scanr1 ((toElem .) . f) (B.unpack x) + , testProperty "scanr1 empty" $ + \f -> B.scanr1 f B.empty === B.empty +#endif + +#if !defined(BYTESTRING_LAZY) && !defined(BYTESTRING_SHORT) + , testProperty "sort" $ + \x -> B.unpack (B.sort x) === List.sort (B.unpack x) +#endif + +#ifndef BYTESTRING_SHORT + , testProperty "intersperse" $ + \(toElem -> c) x -> B.unpack (B.intersperse c x) === List.intersperse c (B.unpack x) +#endif + , testProperty "intercalate" $ + \(Sqrt x) (Sqrt ys) -> B.unpack (B.intercalate x ys) === List.intercalate (B.unpack x) (map B.unpack ys) + , testProperty "intercalate 'c' [x,y]" $ + \(toElem -> c) x y -> B.unpack (B.intercalate (B.singleton c) [x, y]) === List.intercalate [c] [B.unpack x, B.unpack y] + , testProperty "intercalate split" $ + \(toElem -> c) x -> B.intercalate (B.singleton c) (B.split c x) === x + +#ifndef BYTESTRING_SHORT + , testProperty "mapAccumL" $ + \f (toElem -> c) x -> second B.unpack (B.mapAccumL ((second toElem .) . f) c x) === + List.mapAccumL ((second toElem .) . f) c (B.unpack x) + , testProperty "mapAccumR" $ + \f (toElem -> c) x -> second B.unpack (B.mapAccumR ((second toElem .) . f) c x) === + List.mapAccumR ((second toElem .) . f) c (B.unpack x) + + , testProperty "zip" $ + \x y -> B.zip x y === zip (B.unpack x) (B.unpack y) + , testProperty "zipWith" $ + \f x y -> (B.zipWith f x y :: [Int]) === zipWith f (B.unpack x) (B.unpack y) + , testProperty "packZipWith" $ + \f x y -> B.unpack (B.packZipWith ((toElem .) . f) x y) === zipWith ((toElem .) . f) (B.unpack x) (B.unpack y) +# ifdef BYTESTRING_LAZY + -- Don't use (===) in these laziness tests: + -- We don't want printing the test case to fail! + , testProperty "zip is lazy in the longer input" $ zipLazyInLongerInputTest $ + \x y -> B.zip x y == zip (B.unpack x) (B.unpack y) + , testProperty "zipWith is lazy in the longer input" $ + \f -> zipLazyInLongerInputTest $ + \x y -> (B.zipWith f x y :: [Int]) == zipWith f (B.unpack x) (B.unpack y) + , testProperty "packZipWith is lazy in the longer input" $ + \f -> zipLazyInLongerInputTest $ + \x y -> B.unpack (B.packZipWith ((toElem .) . f) x y) == zipWith ((toElem .) . f) (B.unpack x) (B.unpack y) + , testProperty "zip is maximally lazy" $ \x y -> + zip (B.unpack x) (B.unpack y) `List.isPrefixOf` + B.zip (x <> tooStrictErr) (y <> tooStrictErr) + , testProperty "zipWith is maximally lazy" $ \f x y -> + zipWith f (B.unpack x) (B.unpack y) `List.isPrefixOf` + B.zipWith @Int f (x <> tooStrictErr) (y <> tooStrictErr) + -- (It's not clear if packZipWith is required to be maximally lazy.) +# endif + , testProperty "unzip" $ + \(fmap (toElem *** toElem) -> xs) -> (B.unpack *** B.unpack) (B.unzip xs) === unzip xs +#endif + + , testProperty "index" $ + \(NonNegative n) x -> intToIndexTy n < B.length x ==> B.index x (intToIndexTy n) === B.unpack x !! n + , testProperty "indexMaybe" $ + \(NonNegative n) x -> intToIndexTy n < B.length x ==> B.indexMaybe x (intToIndexTy n) === Just (B.unpack x !! n) + , testProperty "indexMaybe Nothing" $ + \n x -> n < 0 || intToIndexTy n >= B.length x ==> B.indexMaybe x (intToIndexTy n) === Nothing + , testProperty "!?" $ + \(intToIndexTy -> n) x -> B.indexMaybe x n === x B.!? n + +#ifdef BYTESTRING_CHAR8 + , testProperty "isString" $ + \x -> x === fromString (B.unpack x) + , testRdInt @Int "readInt" + , testRdInt @Int8 "readInt8" + , testRdInt @Int16 "readInt16" + , testRdInt @Int32 "readInt32" + , testRdInt @Int64 "readInt64" + , testRdInt @Word "readWord" + , testRdInt @Word8 "readWord8" + , testRdInt @Word16 "readWord16" + , testRdInt @Word32 "readWord32" + , testRdInt @Word64 "readWord64" + , testRdInt @Integer "readInteger" + , testRdInt @Natural "readNatural" + , testProperty "lines" $ + \x -> map B.unpack (B.lines x) === lines (B.unpack x) + , testProperty "lines \\n" $ once $ + let x = B.pack "one\ntwo\n\n\nfive\n\nseven\n" in + map B.unpack (B.lines x) === lines (B.unpack x) + , testProperty "unlines" $ + \xs -> B.unpack (B.unlines xs) === unlines (map B.unpack xs) + , testProperty "words" $ + \x -> map B.unpack (B.words x) === words (B.unpack x) + , testProperty "unwords" $ + \xs -> B.unpack (B.unwords xs) === unwords (map B.unpack xs) +#endif + +#ifndef BYTESTRING_LAZY + , testProperty "unfoldrN" $ + \n f (toElem -> c) -> B.unpack (fst (B.unfoldrN n (fmap (first toElem) . f) c)) === + take (fromIntegral n) (List.unfoldr (fmap (first toElem) . f) c) + , testProperty "unfoldrN replicate" $ + \n (toElem -> c) -> fst (B.unfoldrN n (\t -> Just (t, t)) c) === B.replicate n c + , testProperty "unfoldr" $ + \n a (toElem -> c) -> B.unpack (B.unfoldr (\x -> if x <= 100 * n then Just (c, x + 1 :: Int) else Nothing) a) === + List.unfoldr (\x -> if x <= 100 * n then Just (c, x + 1) else Nothing) a +#endif + +#ifdef BYTESTRING_LAZY + , testProperty "unfoldr" $ + \n f (toElem -> a) -> B.unpack (B.take (fromIntegral n) (B.unfoldr (fmap (first toElem) . f) a)) === + take n (List.unfoldr (fmap (first toElem) . f) a) + , testProperty "repeat" $ + \n (toElem -> c) -> B.take (fromIntegral (n :: Int)) (B.repeat c) === + B.take (fromIntegral n) (B.unfoldr (\a -> Just (a, a)) c) + , testProperty "cycle" $ + \n x -> not (B.null x) ==> B.take (fromIntegral (n :: Int)) (B.cycle x) === + B.take (fromIntegral n) (B.concat (List.unfoldr (\a -> Just (a, a)) x)) + , testProperty "iterate" $ + \n f (toElem -> a) -> B.take (fromIntegral (n :: Int)) (B.iterate (toElem . f) a) === + B.take (fromIntegral n) (B.unfoldr (\x -> Just (toElem (f x), toElem (f x))) a) +#endif + +#ifndef BYTESTRING_CHAR8 + -- issue #393 + , testProperty "fromString non-char8" $ + \s -> fromString s == B.pack (map (fromIntegral . ord :: Char -> Word8) s) + , testProperty "fromString literal" $ + fromString "\0\1\2\3\4" == B.pack [0,1,2,3,4] +#endif + +#ifndef BYTESTRING_SHORT + , testProperty "toConstr is pack" $ + \(x :: BYTESTRING_TYPE) -> showConstr (toConstr x) === "pack" +#ifndef BYTESTRING_CHAR8 + , testProperty "gshow" $ + \x -> gshow x === "(pack " ++ gshow (B.unpack x) ++ ")" +#endif +-- -- gread is broken on bytestring-0.12 and fixed on bytestring-master +-- , testProperty "gread . gshow = reads . show" $ +-- \(x :: BYTESTRING_TYPE) -> gread (gshow x) === (reads (show x) :: [(BYTESTRING_TYPE, String)]) +#endif + ] + +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc xs = Just (init xs, last xs) + +#ifndef BYTESTRING_SHORT +findIndexEnd :: (a -> Bool) -> [a] -> Maybe Int +findIndexEnd f xs = fmap (\n -> length xs - 1 - n) (List.findIndex f (reverse xs)) + +elemIndexEnd :: Eq a => a -> [a] -> Maybe Int +elemIndexEnd c xs = fmap (\n -> length xs - 1 - n) (List.elemIndex c (reverse xs)) +#endif + +stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] +stripSuffix x y = fmap reverse (List.stripPrefix (reverse x) (reverse y)) + +split :: Eq a => a -> [a] -> [[a]] +split c = splitWith (== c) + +splitWith :: (a -> Bool) -> [a] -> [[a]] +splitWith _ [] = [] +splitWith f ys = go [] ys + where + go acc [] = [reverse acc] + go acc (x : xs) + | f x = reverse acc : go [] xs + | otherwise = go (x : acc) xs + +#ifdef BYTESTRING_CHAR8 +readInt :: String -> Maybe (Int, String) +readInt xs = case readInteger xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readWord :: String -> Maybe (Word, String) +readWord xs = case readIntegerUnsigned xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readInt8 :: String -> Maybe (Int8, String) +readInt8 xs = case readInteger xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readWord8 :: String -> Maybe (Word8, String) +readWord8 xs = case readIntegerUnsigned xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readInt16 :: String -> Maybe (Int16, String) +readInt16 xs = case readInteger xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readWord16 :: String -> Maybe (Word16, String) +readWord16 xs = case readIntegerUnsigned xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readInt32 :: String -> Maybe (Int32, String) +readInt32 xs = case readInteger xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readWord32 :: String -> Maybe (Word32, String) +readWord32 xs = case readIntegerUnsigned xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readInt64 :: String -> Maybe (Int64, String) +readInt64 xs = case readInteger xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readWord64 :: String -> Maybe (Word64, String) +readWord64 xs = case readIntegerUnsigned xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readInteger :: String -> Maybe (Integer, String) +readInteger ('+' : xs) = readIntegerUnsigned xs +readInteger ('-' : xs) = fmap (first negate) (readIntegerUnsigned xs) +readInteger xs = readIntegerUnsigned xs + +readNatural :: String -> Maybe (Natural, String) +readNatural xs = case readIntegerUnsigned xs of + Just (y, zs) + | y >= 0 -> Just (fromIntegral @Integer @Natural y, zs) + _ -> Nothing + +readIntegerUnsigned :: String -> Maybe (Integer, String) +readIntegerUnsigned xs = case readMaybe ys of + Just y -> Just (y, zs) + otherwise -> Nothing + where + (ys, zs) = span isDigit xs +#endif + +#ifdef BYTESTRING_LAZY +zipLazyInLongerInputTest + :: Testable prop + => (BYTESTRING_TYPE -> BYTESTRING_TYPE -> prop) + -> BYTESTRING_TYPE -> BYTESTRING_TYPE -> Property +zipLazyInLongerInputTest fun = \x0 y0 -> let + msg = "Input chunks are: " ++ show (B.toChunks x0, B.toChunks y0) + (x, y) | B.length x0 <= B.length y0 + = (x0, y0 <> tooStrictErr) + | otherwise + = (x0 <> tooStrictErr, y0) + in counterexample msg (fun x y) +#endif diff --git a/tests/Properties/ByteStringChar8.hs b/tests/Properties/ByteStringChar8.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ByteStringChar8.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} + +#define BYTESTRING_CHAR8 + +#include "ByteString.hs" diff --git a/tests/Properties/ByteStringLazy.hs b/tests/Properties/ByteStringLazy.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ByteStringLazy.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} + +#define BYTESTRING_LAZY + +#include "ByteString.hs" diff --git a/tests/Properties/ByteStringLazyChar8.hs b/tests/Properties/ByteStringLazyChar8.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ByteStringLazyChar8.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE CPP #-} + +#define BYTESTRING_LAZY +#define BYTESTRING_CHAR8 + +#include "ByteString.hs" diff --git a/tests/Properties/ShortByteString.hs b/tests/Properties/ShortByteString.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ShortByteString.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} + +#define BYTESTRING_SHORT + +#include "ByteString.hs" diff --git a/tests/QuickCheckUtils.hs b/tests/QuickCheckUtils.hs --- a/tests/QuickCheckUtils.hs +++ b/tests/QuickCheckUtils.hs @@ -1,203 +1,142 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, - FlexibleInstances, TypeSynonymInstances #-} --- --- Uses multi-param type classes --- -module QuickCheckUtils where +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} -import Test.QuickCheck +module QuickCheckUtils + ( Char8(..) + , String8(..) + , CByteString(..) + , Sqrt(..) + , int64OK + , tooStrictErr + ) where + +import Test.Tasty.QuickCheck import Text.Show.Functions import Control.Monad ( liftM2 ) -import Control.Monad.Instances import Data.Char -import Data.List import Data.Word import Data.Int -import System.Random import System.IO import Foreign.C (CChar) +import GHC.TypeLits (TypeError, ErrorMessage(..)) +import GHC.Stack (withFrozenCallStack, HasCallStack) +import qualified Data.ByteString.Short as SB import qualified Data.ByteString as P import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Internal as L (checkInvariant,ByteString(..)) import qualified Data.ByteString.Char8 as PC import qualified Data.ByteString.Lazy.Char8 as LC ------------------------------------------------------------------------ -adjustSize :: Testable prop => (Int -> Int) -> prop -> Property -adjustSize f p = sized $ \sz -> resize (f sz) (property p) - ------------------------------------------------------------------------- - -{- - --- HUGS needs: - -instance Functor ((->) r) where - fmap = (.) - -instance (Arbitrary a) => Arbitrary (Maybe a) where - arbitrary = sized arbMaybe - where - arbMaybe 0 = return Nothing - arbMaybe n = fmap Just (resize (n-1) arbitrary) - coarbitrary Nothing = variant 0 - coarbitrary (Just x) = variant 1 . coarbitrary x - -instance Monad ((->) r) where - return = const - f >>= k = \ r -> k (f r) r - -instance Functor ((,) a) where - fmap f (x,y) = (x, f y) - -instance Functor (Either a) where - fmap _ (Left x) = Left x - fmap f (Right y) = Right (f y) - --} - ------------------------------------------------------------------------- - -integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) -integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, - fromIntegral b :: Integer) g of - (x,g) -> (fromIntegral x, g) - -instance Arbitrary L.ByteString where - arbitrary = return . L.checkInvariant - . L.fromChunks - . filter (not. P.null) -- maintain the invariant. - =<< arbitrary - -instance CoArbitrary L.ByteString where - coarbitrary s = coarbitrary (L.unpack s) +sizedByteString n = do m <- choose(0, n) + fmap P.pack $ vectorOf m arbitrary instance Arbitrary P.ByteString where arbitrary = do - bs <- P.pack `fmap` arbitrary + bs <- sized sizedByteString n <- choose (0, 2) return (P.drop n bs) -- to give us some with non-0 offset + shrink = map P.pack . shrink . P.unpack instance CoArbitrary P.ByteString where coarbitrary s = coarbitrary (P.unpack s) +instance Arbitrary L.ByteString where + arbitrary = sized $ \n -> do numChunks <- choose (0, n) + if numChunks == 0 + then return L.empty + else fmap (L.fromChunks . + filter (not . P.null)) $ + vectorOf numChunks + (sizedByteString + (n `div` numChunks)) + shrink = map L.fromChunks . shrink . L.toChunks + +instance CoArbitrary L.ByteString where + coarbitrary s = coarbitrary (L.unpack s) + newtype CByteString = CByteString P.ByteString deriving Show instance Arbitrary CByteString where - arbitrary = fmap (CByteString . P.pack . map fromCChar) arbitrary + arbitrary = fmap (CByteString . P.pack . map fromCChar) + arbitrary where - fromCChar :: CChar -> Word8 - fromCChar = fromIntegral - -instance Arbitrary CChar where - arbitrary = fmap (fromIntegral :: Int -> CChar) - $ oneof [choose (-128,-1), choose (1,127)] + fromCChar :: NonZero CChar -> Word8 + fromCChar = fromIntegral . getNonZero ------------------------------------------------------------------------- --- --- We're doing two forms of testing here. Firstly, model based testing. --- For our Lazy and strict bytestring types, we have model types: --- --- i.e. Lazy == Byte --- \\ // --- List --- --- That is, the Lazy type can be modeled by functions in both the Byte --- and List type. For each of the 3 models, we have a set of tests that --- check those types match. --- --- The Model class connects a type and its model type, via a conversion --- function. --- +-- | 'Char', but only representing 8-bit characters. -- -class Model a b where - model :: a -> b -- get the abstract vale from a concrete value +newtype Char8 = Char8 Char + deriving (Eq, Ord, Show) --- --- Connecting our Lazy and Strict types to their models. We also check --- the data invariant on Lazy types. --- --- These instances represent the arrows in the above diagram --- -instance Model B P where model = abstr . checkInvariant -instance Model P [W] where model = P.unpack -instance Model P [Char] where model = PC.unpack -instance Model B [W] where model = L.unpack . checkInvariant -instance Model B [Char] where model = LC.unpack . checkInvariant -instance Model Char Word8 where model = fromIntegral . ord +instance Arbitrary Char8 where + arbitrary = fmap (Char8 . toChar) arbitrary + where + toChar :: Word8 -> Char + toChar = toEnum . fromIntegral + shrink (Char8 c) = fmap Char8 (shrink c) --- Types are trivially modeled by themselves -instance Model Bool Bool where model = id -instance Model Int Int where model = id -instance Model P P where model = id -instance Model B B where model = id -instance Model Int64 Int64 where model = id -instance Model Word8 Word8 where model = id -instance Model Ordering Ordering where model = id -instance Model Char Char where model = id +instance CoArbitrary Char8 where + coarbitrary (Char8 c) = coarbitrary c --- More structured types are modeled recursively, using the NatTrans class from Gofer. -class (Functor f, Functor g) => NatTrans f g where - eta :: f a -> g a +-- | 'Char', but only representing 8-bit characters. +-- +newtype String8 = String8 String + deriving (Eq, Ord, Show) --- The transformation of the same type is identity -instance NatTrans [] [] where eta = id -instance NatTrans Maybe Maybe where eta = id -instance NatTrans ((->) X) ((->) X) where eta = id -instance NatTrans ((->) Char) ((->) Char) where eta = id +instance Arbitrary String8 where + arbitrary = fmap (String8 . map toChar) arbitrary + where + toChar :: Word8 -> Char + toChar = toEnum . fromIntegral + shrink (String8 xs) = fmap String8 (shrink xs) -instance NatTrans ((->) W) ((->) W) where eta = id +-- | If a test takes O(n^2) time or memory, it's useful to wrap its inputs +-- into 'Sqrt' so that increasing number of tests affects run time linearly. +newtype Sqrt a = Sqrt { unSqrt :: a } + deriving (Eq, Show) --- We have a transformation of pairs, if the pairs are in Model -instance Model f g => NatTrans ((,) f) ((,) g) where eta (f,a) = (model f, a) +instance Arbitrary a => Arbitrary (Sqrt a) where + arbitrary = Sqrt <$> sized + (\n -> resize (round @Double $ sqrt $ fromIntegral @Int n) arbitrary) + shrink = map Sqrt . shrink . unSqrt --- And finally, we can take any (m a) to (n b), if we can Model m n, and a b -instance (NatTrans m n, Model a b) => Model (m a) (n b) where model x = fmap model (eta x) ------------------------------------------------------------------------- - --- In a form more useful for QC testing (and it's lazy) -checkInvariant :: L.ByteString -> L.ByteString -checkInvariant = L.checkInvariant - -abstr :: L.ByteString -> P.ByteString -abstr = P.concat . L.toChunks +sizedShortByteString :: Int -> Gen SB.ShortByteString +sizedShortByteString n = do m <- choose(0, n) + fmap SB.pack $ vectorOf m arbitrary --- Some short hand. -type X = Int -type W = Word8 -type P = P.ByteString -type B = L.ByteString +instance Arbitrary SB.ShortByteString where + arbitrary = sized sizedShortByteString + shrink = map SB.pack . shrink . SB.unpack ------------------------------------------------------------------------- --- --- These comparison functions handle wrapping and equality. --- --- A single class for these would be nice, but note that they differe in --- the number of arguments, and those argument types, so we'd need HList --- tricks. See here: http://okmij.org/ftp/Haskell/vararg-fn.lhs --- +instance CoArbitrary SB.ShortByteString where + coarbitrary s = coarbitrary (SB.unpack s) -eq1 f g = \a -> - model (f a) == g (model a) -eq2 f g = \a b -> - model (f a b) == g (model a) (model b) -eq3 f g = \a b c -> - model (f a b c) == g (model a) (model b) (model c) +-- | This /poison instance/ exists to make accidental mis-use +-- of the @Arbitrary Int64@ instance a bit less likely. +instance {-# OVERLAPPING #-} + TypeError (Text "Found a test taking a raw Int64 argument." + :$$: Text "'instance Arbitrary Int64' by default is likely to" + :$$: Text "produce very large numbers after the first few tests," + :$$: Text "which doesn't make great indices into a LazyByteString." + :$$: Text "For indices, try 'intToIndexTy' in Properties/ByteString.hs." + :$$: Text "" + :$$: Text "If very few small-numbers tests is OK, use" + :$$: Text "'int64OK' to bypass this poison-instance." + ) => Testable (Int64 -> prop) where + property = error "poison instance Testable (Int64 -> prop)" --- --- And for functions that take non-null input --- -eqnotnull1 f g = \x -> (not (isNull x)) ==> eq1 f g x -eqnotnull2 f g = \x y -> (not (isNull y)) ==> eq2 f g x y -eqnotnull3 f g = \x y z -> (not (isNull z)) ==> eq3 f g x y z +-- | Use this to bypass the poison instance for @Testable (Int64 -> prop)@ +-- defined in "QuickCheckUtils". +int64OK :: (Arbitrary a, Show a, Testable b) => (a -> b) -> Property +int64OK f = propertyForAllShrinkShow arbitrary shrink (\v -> [show v]) f -class IsNull t where isNull :: t -> Bool -instance IsNull L.ByteString where isNull = L.null -instance IsNull P.ByteString where isNull = P.null +tooStrictErr :: forall a. HasCallStack => a +tooStrictErr = withFrozenCallStack $ + error "A lazy sub-expression was unexpectedly evaluated" diff --git a/tests/Rules.hs b/tests/Rules.hs deleted file mode 100644 --- a/tests/Rules.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Rules where --- --- Tests to ensure rules are firing. --- - -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString as P -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Char8 as D -import Data.List -import Data.Char - -import QuickCheckUtils -import TestFramework - - -prop_break_C x = C.break ((==) x) `eq1` break ((==) x) -prop_break_P x = P.break ((==) x) `eq1` break ((==) x) -prop_intercalate_P c = (\s1 s2 -> P.intercalate (P.singleton c) (s1 : s2 : [])) - `eq2` - (\s1 s2 -> intercalate [c] (s1 : s2 : [])) - -prop_break_isSpace_C = C.break isSpace `eq1` break isSpace -prop_dropWhile_isSpace_C = C.dropWhile isSpace `eq1` dropWhile isSpace - -rules = - [ testProperty "break (==)" prop_break_C - , testProperty "break (==)" prop_break_P - , testProperty "break isSpace" prop_break_isSpace_C - , testProperty "dropWhile isSpace" prop_dropWhile_isSpace_C - , testProperty "intercalate" prop_intercalate_P - ] diff --git a/tests/TestFramework.hs b/tests/TestFramework.hs deleted file mode 100644 --- a/tests/TestFramework.hs +++ /dev/null @@ -1,67 +0,0 @@ --- | --- Copyright : (c) 2011 Duncan Coutts --- --- test-framework stub API --- --- Currently we cannot use the nice test-framework package for this testsuite --- since test-framework indirectly depends on bytestring and this makes cabal --- think we've got a circular dependency. --- --- On the other hand, it's very nice to have the testsuite run automatically --- rather than being a totally separate package (which would fix). --- --- So until we can fix that we implement our own trivial layer. --- -module TestFramework where - -import Test.QuickCheck (Testable(..)) -import Test.QuickCheck.Test - -import Text.Printf -import System.Environment -import Control.Monad -import Control.Exception - --- Ideally we'd be using: - ---import Test.Framework ---import Test.Framework.Providers.QuickCheck2 - -type TestName = String -type Test = [(TestName, Int -> IO (Bool, Int))] - -testGroup :: String -> [Test] -> Test -testGroup _ = concat - -testProperty :: Testable a => String -> a -> Test -testProperty name p = [(name, runQcTest)] - where - runQcTest n = do - result <- quickCheckWithResult testArgs p - case result of - Success {} -> return (True, numTests result) - _ -> return (False, numTests result) - where - testArgs = stdArgs { - maxSuccess = n - --chatty = ... if we want to increase verbosity - } - -testCase :: String -> Bool -> Test -testCase name tst = [(name, runPlainTest)] - where - runPlainTest _ = do - r <- evaluate tst - putStrLn "+++ OK, passed test." - return (r, 1) - -defaultMain :: [Test] -> IO () -defaultMain = runTests . concat - -runTests :: [(String, Int -> IO (Bool,Int))] -> IO () -runTests tests = do - x <- getArgs - let n = if null x then 100 else read . head $ x - (results, passed) <- liftM unzip $ mapM (\(s,a) -> printf "%-40s: " s >> a n) tests - _ <- printf "Passed %d tests!\n" (sum passed) - when (not . and $ results) $ fail "Not all tests passed!" diff --git a/tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs b/tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs @@ -0,0 +1,381 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Testing utilities for comparing +-- for an example on how to use the functions provided here. +-- +module Data.ByteString.Builder.Prim.TestUtils ( + + -- * Showing + evalF + , evalB + + , showF + , showB + + -- * Testing 'FixedPrim's + , testF + , testBoundedF + + , testFixedBoundF + + , compareImpls + + -- * Testing 'BoundedPrim's + , testBoundedB + + -- * Encoding reference implementations + + , charUtf8_list + , char8_list + + -- ** ASCII-based encodings + , encodeASCII + , encodeForcedASCII + , char7_list + , dec_list + , hex_list + , wordHexFixed_list + , int8HexFixed_list + , int16HexFixed_list + , int32HexFixed_list + , int64HexFixed_list + , floatHexFixed_list + , doubleHexFixed_list + + -- ** Binary + , parseVar + + , bigEndian_list + , littleEndian_list + , hostEndian_list + , float_list + , double_list + , coerceFloatToWord32 + , coerceDoubleToWord64 + , coerceWord32ToFloat + , coerceWord64ToDouble + + ) where + +import Control.Arrow (first) + +import Data.ByteString.Builder.Prim + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Builder.Prim.Internal as I + +import Data.Bits (Bits(..)) +import Data.Char (chr, ord) +import Data.Int +import Data.Word +import Foreign (Storable(..), castPtr, minusPtr, with) +import Numeric (showHex) +import System.IO.Unsafe (unsafePerformIO) + +import Test.Tasty +import Test.Tasty.QuickCheck (Arbitrary(..), testProperty) + +#include + +-- Helper functions +------------------- + +-- | Quickcheck test that includes a check that the property holds on the +-- bounds of a bounded value. +testBoundedProperty :: forall a. (Arbitrary a, Show a, Bounded a) + => String -> (a -> Bool) -> TestTree +testBoundedProperty name p = testGroup name + [ testProperty name p + , testProperty (name ++ " minBound") (p (minBound :: a)) + , testProperty (name ++ " maxBound") (p (maxBound :: a)) + ] + +-- | Quote a 'String' nicely. +quote :: String -> String +quote cs = '`' : cs ++ "'" + +-- | Quote a @[Word8]@ list as as 'String'. +quoteWord8s :: [Word8] -> String +quoteWord8s = quote . map (chr . fromIntegral) + + +------------------------------------------------------------------------------ +-- Testing encodings +------------------------------------------------------------------------------ + +-- | /For testing use only./ Evaluate a 'FixedPrim' on a given value. +evalF :: FixedPrim a -> a -> [Word8] +evalF fe = S.unpack . S.unsafeCreate (I.size fe) . I.runF fe + +-- | /For testing use only./ Evaluate a 'BoundedPrim' on a given value. +evalB :: BoundedPrim a -> a -> [Word8] +evalB be x = S.unpack $ unsafePerformIO $ + S.createAndTrim (I.sizeBound be) $ \op -> do + op' <- I.runB be x op + return (op' `minusPtr` op) + +-- | /For testing use only./ Show the result of a 'FixedPrim' of a given +-- value as a 'String' by interpreting the resulting bytes as Unicode +-- codepoints. +showF :: FixedPrim a -> a -> String +showF fe = map (chr . fromIntegral) . evalF fe + +-- | /For testing use only./ Show the result of a 'BoundedPrim' of a given +-- value as a 'String' by interpreting the resulting bytes as Unicode +-- codepoints. +showB :: BoundedPrim a -> a -> String +showB be = map (chr . fromIntegral) . evalB be + + +-- FixedPrim +---------------- + +-- TODO: Port code that checks for low-level properties of basic encodings (no +-- overwrites, all bytes written, etc.) from old 'system-io-write' library + +-- | Test a 'FixedPrim' against a reference implementation. +testF :: (Arbitrary a, Show a) + => String + -> (a -> [Word8]) + -> FixedPrim a + -> TestTree +testF name ref fe = + testProperty name prop + where + prop x + | y == y' = True + | otherwise = error $ unlines $ + [ "testF: results disagree for " ++ quote (show x) + , " fixed encoding: " ++ show y ++ " " ++ quoteWord8s y + , " reference: " ++ show y'++ " " ++ quoteWord8s y' + ] + where + y = evalF fe x + y' = ref x + +-- | Test a 'FixedPrim' of a bounded value against a reference implementation +-- and ensure that the bounds are always included as testcases. +testBoundedF :: (Arbitrary a, Bounded a, Show a) + => String + -> (a -> [Word8]) + -> FixedPrim a + -> TestTree +testBoundedF name ref fe = + testBoundedProperty name $ \x -> evalF fe x == ref x + +-- FixedPrim derived from a bound on a given value. + +testFixedBoundF :: (Arbitrary a, Show a, Integral a) + => String + -> (a -> a -> [Word8]) + -> (a -> FixedPrim a) + -> TestTree +testFixedBoundF name ref bfe = + testProperty name prop + where + prop (b, x0) + | y == y' = True + | otherwise = error $ unlines $ + [ "testF: results disagree for " ++ quote (show (b, x)) + , " fixed encoding: " ++ show y ++ " " ++ quoteWord8s y + , " reference: " ++ show y'++ " " ++ quoteWord8s y' + ] + where + x | b == 0 = 0 + | otherwise = x0 `mod` b + y = evalF (bfe b) x + y' = ref b x + + +-- BoundedPrim +------------------ + +-- | Test a 'BoundedPrim' of a bounded value against a reference implementation +-- and ensure that the bounds are always included as testcases. +testBoundedB :: (Arbitrary a, Bounded a, Show a) + => String + -> (a -> [Word8]) + -> BoundedPrim a + -> TestTree +testBoundedB name ref fe = + testBoundedProperty name check + where + check x + | y == y' = True + | otherwise = error $ unlines $ + [ "testBoundedB: results disagree for " ++ quote (show x) + , " fixed encoding: " ++ show y ++ " " ++ quoteWord8s y + , " reference: " ++ show y'++ " " ++ quoteWord8s y' + ] + where + y = evalB fe x + y' = ref x + +-- | Compare two implementations of a function. +compareImpls :: (Arbitrary a, Show a, Show b, Eq b) + => TestName -> (a -> b) -> (a -> b) -> TestTree +compareImpls name f1 f2 = + testProperty name check + where + check x + | y1 == y2 = True + | otherwise = error $ unlines $ + [ "compareImpls: results disagree for " ++ quote (show x) + , " f1: " ++ show y1 + , " f2: " ++ show y2 + ] + where + y1 = f1 x + y2 = f2 x + + + +------------------------------------------------------------------------------ +-- Encoding reference implementations +------------------------------------------------------------------------------ + +-- | Char8 encoding: truncate Unicode codepoint to 8-bits. +char8_list :: Char -> [Word8] +char8_list = return . fromIntegral . ord + +-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +-- +-- Copied from 'utf8-string-0.3.6' to make tests self-contained. +-- Copyright (c) 2007, Galois Inc. All rights reserved. +-- +charUtf8_list :: Char -> [Word8] +charUtf8_list = + map fromIntegral . encode . ord + where + encode oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) + , 0x80 + oc .&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) + , 0x80 + ((oc `shiftR` 6) .&. 0x3f) + , 0x80 + oc .&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `shiftR` 18) + , 0x80 + ((oc `shiftR` 12) .&. 0x3f) + , 0x80 + ((oc `shiftR` 6) .&. 0x3f) + , 0x80 + oc .&. 0x3f + ] + +-- ASCII-based encodings +------------------------ + +-- | Encode a 'String' of only ASCII characters using the ASCII encoding. +encodeASCII :: String -> [Word8] +encodeASCII = + map encode + where + encode c + | c < '\x7f' = fromIntegral $ ord c + | otherwise = error $ "encodeASCII: non-ASCII character '" ++ [c] ++ "'" + +-- | Encode an arbitrary 'String' by truncating its characters to the least +-- significant 7-bits. +encodeForcedASCII :: String -> [Word8] +encodeForcedASCII = map ((.&. 0x7f) . fromIntegral . ord) + +char7_list :: Char -> [Word8] +char7_list = encodeForcedASCII . return + +dec_list :: Show a => a -> [Word8] +dec_list = encodeASCII . show + +hex_list :: (Integral a, Show a) => a -> [Word8] +hex_list = encodeASCII . (\x -> showHex x "") + +wordHexFixed_list :: (Storable a, Integral a, Show a) => a -> [Word8] +wordHexFixed_list x = + encodeASCII $ pad (2 * sizeOf x) $ showHex x "" + where + pad n cs = replicate (n - length cs) '0' ++ cs + +int8HexFixed_list :: Int8 -> [Word8] +int8HexFixed_list = wordHexFixed_list . (fromIntegral :: Int8 -> Word8 ) + +int16HexFixed_list :: Int16 -> [Word8] +int16HexFixed_list = wordHexFixed_list . (fromIntegral :: Int16 -> Word16) + +int32HexFixed_list :: Int32 -> [Word8] +int32HexFixed_list = wordHexFixed_list . (fromIntegral :: Int32 -> Word32) + +int64HexFixed_list :: Int64 -> [Word8] +int64HexFixed_list = wordHexFixed_list . (fromIntegral :: Int64 -> Word64) + +floatHexFixed_list :: Float -> [Word8] +floatHexFixed_list = float_list wordHexFixed_list + +doubleHexFixed_list :: Double -> [Word8] +doubleHexFixed_list = double_list wordHexFixed_list + +-- Binary +--------- + +bigEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8] +bigEndian_list = reverse . littleEndian_list + +littleEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8] +littleEndian_list x = + map (fromIntegral . (x `shiftR`) . (8*)) $ [0..sizeOf x - 1] + +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/20338 +-- and https://gitlab.haskell.org/ghc/ghc/-/issues/18445 +hostEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8] +#if defined(WORDS_BIGENDIAN) +hostEndian_list = bigEndian_list +#else +hostEndian_list = littleEndian_list +#endif + +float_list :: (Word32 -> [Word8]) -> Float -> [Word8] +float_list f = f . coerceFloatToWord32 + +double_list :: (Word64 -> [Word8]) -> Double -> [Word8] +double_list f = f . coerceDoubleToWord64 + +-- | Convert a 'Float' to a 'Word32'. +{-# NOINLINE coerceFloatToWord32 #-} +coerceFloatToWord32 :: Float -> Word32 +coerceFloatToWord32 x = unsafePerformIO (with x (peek . castPtr)) + +-- | Convert a 'Double' to a 'Word64'. +{-# NOINLINE coerceDoubleToWord64 #-} +coerceDoubleToWord64 :: Double -> Word64 +coerceDoubleToWord64 x = unsafePerformIO (with x (peek . castPtr)) + +-- | Convert a 'Word32' to a 'Float'. +{-# NOINLINE coerceWord32ToFloat #-} +coerceWord32ToFloat :: Word32 -> Float +coerceWord32ToFloat x = unsafePerformIO (with x (peek . castPtr)) + +-- | Convert a 'Word64' to a 'Double'. +{-# NOINLINE coerceWord64ToDouble #-} +coerceWord64ToDouble :: Word64 -> Double +coerceWord64ToDouble x = unsafePerformIO (with x (peek . castPtr)) + +-- | Parse a variable length encoding +parseVar :: (Num a, Bits a) => [Word8] -> (a, [Word8]) +parseVar = + go + where + go [] = error "parseVar: unterminated variable length int" + go (w:ws) + | w .&. 0x80 == 0 = (fromIntegral w, ws) + | otherwise = first add (go ws) + where + add x = (x `shiftL` 7) .|. (fromIntegral w .&. 0x7f) diff --git a/tests/builder/Data/ByteString/Builder/Prim/Tests.hs b/tests/builder/Data/ByteString/Builder/Prim/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/builder/Data/ByteString/Builder/Prim/Tests.hs @@ -0,0 +1,172 @@ +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Testing all encodings provided by this library. + +module Data.ByteString.Builder.Prim.Tests (tests) where + +import Data.Char (ord) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC +import Data.ByteString.Builder +import qualified Data.ByteString.Builder.Prim as BP +import Data.ByteString.Builder.Prim.TestUtils + +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: [TestTree] +tests = concat [ testsBinary, testsASCII, testsChar8, testsUtf8 + , testsCombinatorsB, [testCString, testCStringUtf8] ] + +testCString :: TestTree +testCString = testProperty "cstring" $ + toLazyByteString (BP.cstring "hello world!"#) == + LC.pack "hello" `L.append` L.singleton 0x20 `L.append` LC.pack "world!" + +testCStringUtf8 :: TestTree +testCStringUtf8 = testProperty "cstringUtf8" $ + toLazyByteString (BP.cstringUtf8 "hello\xc0\x80world!"#) == + LC.pack "hello" `L.append` L.singleton 0x00 `L.append` LC.pack "world!" + +------------------------------------------------------------------------------ +-- Binary +------------------------------------------------------------------------------ + +testsBinary :: [TestTree] +testsBinary = + [ testBoundedF "word8" bigEndian_list BP.word8 + , testBoundedF "int8" bigEndian_list BP.int8 + + -- big-endian + , testBoundedF "int16BE" bigEndian_list BP.int16BE + , testBoundedF "int32BE" bigEndian_list BP.int32BE + , testBoundedF "int64BE" bigEndian_list BP.int64BE + + , testBoundedF "word16BE" bigEndian_list BP.word16BE + , testBoundedF "word32BE" bigEndian_list BP.word32BE + , testBoundedF "word64BE" bigEndian_list BP.word64BE + + , testF "floatLE" (float_list littleEndian_list) BP.floatLE + , testF "doubleLE" (double_list littleEndian_list) BP.doubleLE + + -- little-endian + , testBoundedF "int16LE" littleEndian_list BP.int16LE + , testBoundedF "int32LE" littleEndian_list BP.int32LE + , testBoundedF "int64LE" littleEndian_list BP.int64LE + + , testBoundedF "word16LE" littleEndian_list BP.word16LE + , testBoundedF "word32LE" littleEndian_list BP.word32LE + , testBoundedF "word64LE" littleEndian_list BP.word64LE + + , testF "floatBE" (float_list bigEndian_list) BP.floatBE + , testF "doubleBE" (double_list bigEndian_list) BP.doubleBE + + -- host dependent + , testBoundedF "int16Host" hostEndian_list BP.int16Host + , testBoundedF "int32Host" hostEndian_list BP.int32Host + , testBoundedF "int64Host" hostEndian_list BP.int64Host + , testBoundedF "intHost" hostEndian_list BP.intHost + + , testBoundedF "word16Host" hostEndian_list BP.word16Host + , testBoundedF "word32Host" hostEndian_list BP.word32Host + , testBoundedF "word64Host" hostEndian_list BP.word64Host + , testBoundedF "wordHost" hostEndian_list BP.wordHost + + , testF "floatHost" (float_list hostEndian_list) BP.floatHost + , testF "doubleHost" (double_list hostEndian_list) BP.doubleHost + ] + + +------------------------------------------------------------------------------ +-- Latin-1 aka Char8 +------------------------------------------------------------------------------ + +testsChar8 :: [TestTree] +testsChar8 = + [ testBoundedF "char8" char8_list BP.char8 ] + + +------------------------------------------------------------------------------ +-- ASCII +------------------------------------------------------------------------------ + +testsASCII :: [TestTree] +testsASCII = + [ testBoundedF "char7" char7_list BP.char7 + + , testBoundedB "int8Dec" dec_list BP.int8Dec + , testBoundedB "int16Dec" dec_list BP.int16Dec + , testBoundedB "int32Dec" dec_list BP.int32Dec + , testBoundedB "int64Dec" dec_list BP.int64Dec + , testBoundedB "intDec" dec_list BP.intDec + + , testBoundedB "word8Dec" dec_list BP.word8Dec + , testBoundedB "word16Dec" dec_list BP.word16Dec + , testBoundedB "word32Dec" dec_list BP.word32Dec + , testBoundedB "word64Dec" dec_list BP.word64Dec + , testBoundedB "wordDec" dec_list BP.wordDec + + , testBoundedB "word8Hex" hex_list BP.word8Hex + , testBoundedB "word16Hex" hex_list BP.word16Hex + , testBoundedB "word32Hex" hex_list BP.word32Hex + , testBoundedB "word64Hex" hex_list BP.word64Hex + , testBoundedB "wordHex" hex_list BP.wordHex + + , testBoundedF "word8HexFixed" wordHexFixed_list BP.word8HexFixed + , testBoundedF "word16HexFixed" wordHexFixed_list BP.word16HexFixed + , testBoundedF "word32HexFixed" wordHexFixed_list BP.word32HexFixed + , testBoundedF "word64HexFixed" wordHexFixed_list BP.word64HexFixed + + , testBoundedF "int8HexFixed" int8HexFixed_list BP.int8HexFixed + , testBoundedF "int16HexFixed" int16HexFixed_list BP.int16HexFixed + , testBoundedF "int32HexFixed" int32HexFixed_list BP.int32HexFixed + , testBoundedF "int64HexFixed" int64HexFixed_list BP.int64HexFixed + + , testF "floatHexFixed" floatHexFixed_list BP.floatHexFixed + , testF "doubleHexFixed" doubleHexFixed_list BP.doubleHexFixed + ] + + +------------------------------------------------------------------------------ +-- UTF-8 +------------------------------------------------------------------------------ + +testsUtf8 :: [TestTree] +testsUtf8 = + [ testBoundedB "charUtf8" charUtf8_list BP.charUtf8 ] + + +------------------------------------------------------------------------------ +-- BoundedPrim combinators +------------------------------------------------------------------------------ + +maybeB :: BP.BoundedPrim () -> BP.BoundedPrim a -> BP.BoundedPrim (Maybe a) +maybeB nothing just = maybe (Left ()) Right BP.>$< BP.eitherB nothing just + +testsCombinatorsB :: [TestTree] +testsCombinatorsB = + [ compareImpls "mapMaybe (via BoundedPrim)" + (L.pack . concatMap encChar) + (toLazyByteString . encViaBuilder) + + , compareImpls "filter (via BoundedPrim)" + (L.pack . filter (< 32)) + (toLazyByteString . BP.primMapListBounded (BP.condB (< 32) (BP.liftFixedToBounded BP.word8) BP.emptyB)) + + , compareImpls "pairB" + (L.pack . concatMap (\(c,w) -> charUtf8_list c ++ [w])) + (toLazyByteString . BP.primMapListBounded + ((\(c,w) -> (c,(w,undefined))) BP.>$< + BP.charUtf8 BP.>*< (BP.liftFixedToBounded BP.word8) BP.>*< (BP.liftFixedToBounded BP.emptyF))) + ] + where + encChar = maybe [112] (hostEndian_list . ord) + + encViaBuilder = BP.primMapListBounded $ maybeB (BP.liftFixedToBounded $ (\_ -> 112) BP.>$< BP.word8) + (ord BP.>$< (BP.liftFixedToBounded $ BP.intHost)) diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs b/tests/builder/Data/ByteString/Builder/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/builder/Data/ByteString/Builder/Tests.hs @@ -0,0 +1,1025 @@ +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Testing composition of 'Builders'. + +module Data.ByteString.Builder.Tests (tests) where + +import Prelude hiding (writeFile) + +import Control.Applicative +import Control.Monad (unless, void) +import Control.Monad.Trans.State (StateT, evalStateT, evalState, put, get) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Writer (WriterT, execWriterT, tell) + +import Foreign (minusPtr, castPtr, ForeignPtr, withForeignPtr, Int64) + +import Data.Char (chr) +import Data.Bits ((.|.), shiftL) +import Data.Foldable +import Data.Semigroup (Semigroup(..)) +import Data.Word + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Short as Sh + +import Data.ByteString.Builder +import Data.ByteString.Builder.Extra +import Data.ByteString.Builder.Internal (Put, putBuilder, fromPut) +import qualified Data.ByteString.Builder.Internal as BI +import qualified Data.ByteString.Builder.Prim as BP +import Data.ByteString.Builder.Prim.TestUtils + +import Control.Exception (evaluate) +import System.IO (openTempFile, hPutStr, hClose, hSetBinaryMode, hSetEncoding, utf8, hSetNewlineMode, noNewlineTranslation) +import Foreign.C.String (withCString) +import Numeric (showFFloat) +import System.Posix.Internals (c_unlink) + +import Test.Tasty (TestTree, TestName, testGroup) +import Test.Tasty.QuickCheck + ( Arbitrary(..), oneof, choose, listOf, elements + , counterexample, ioProperty, Property, testProperty + , (===), (.&&.), conjoin, forAll, forAllShrink + , UnicodeString(..), NonNegative(..), Positive(..) + , mapSize, (==>) + ) +import QuickCheckUtils + + +tests :: [TestTree] +tests = + [ testBuilderRecipe + , testHandlePutBuilder + , testHandlePutBuilderChar8 + , testPut + , testRunBuilder + , testWriteFile + , testStimes + ] ++ + testsEncodingToBuilder ++ + testsBinary ++ + testsASCII ++ + testsFloating ++ + testsChar8 ++ + testsUtf8 ++ + [testLaziness] + + +------------------------------------------------------------------------------ +-- Testing 'Builder' execution +------------------------------------------------------------------------------ + +testBuilderRecipe :: TestTree +testBuilderRecipe = + testProperty "toLazyByteStringWith" $ testRecipe <$> arbitrary + where + testRecipe r = + counterexample msg $ x1 == x2 + where + x1 = renderRecipe r + x2 = buildRecipe r + toString = map (chr . fromIntegral) + msg = unlines + [ "recipe: " ++ show r + , "render: " ++ toString x1 + , "build : " ++ toString x2 + , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) + ] + +testHandlePutBuilder :: TestTree +testHandlePutBuilder = + testProperty "hPutBuilder" testRecipe + where + testRecipe :: (UnicodeString, UnicodeString, UnicodeString, Recipe) -> Property + testRecipe args = + ioProperty $ do + let { ( UnicodeString before + , UnicodeString between + , UnicodeString after + , recipe) = args } + (tempFile, tempH) <- openTempFile "." "test-builder.tmp" + -- switch to UTF-8 encoding + hSetEncoding tempH utf8 + hSetNewlineMode tempH noNewlineTranslation + -- output recipe with intermediate direct writing to handle + let b = fst $ recipeComponents recipe + hPutStr tempH before + hPutBuilder tempH b + hPutStr tempH between + hPutBuilder tempH b + hPutStr tempH after + hClose tempH + -- read file + lbs <- L.readFile tempFile + _ <- evaluate (L.length $ lbs) + removeFile tempFile + -- compare to pure builder implementation + let lbsRef = toLazyByteString $ fold + [stringUtf8 before, b, stringUtf8 between, b, stringUtf8 after] + -- report + let msg = unlines + [ "task: " ++ show args + , "via file: " ++ show lbs + , "direct : " ++ show lbsRef + -- , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) + ] + success = lbs == lbsRef + unless success (error msg) + return success + +testHandlePutBuilderChar8 :: TestTree +testHandlePutBuilderChar8 = + testProperty "char8 hPutBuilder" testRecipe + where + testRecipe :: (String, String, String, Recipe) -> Property + testRecipe args@(before, between, after, recipe) = ioProperty $ do + (tempFile, tempH) <- openTempFile "." "TestBuilder" + -- switch to binary / latin1 encoding + hSetBinaryMode tempH True + -- output recipe with intermediate direct writing to handle + let b = fst $ recipeComponents recipe + hPutStr tempH before + hPutBuilder tempH b + hPutStr tempH between + hPutBuilder tempH b + hPutStr tempH after + hClose tempH + -- read file + lbs <- L.readFile tempFile + _ <- evaluate (L.length $ lbs) + removeFile tempFile + -- compare to pure builder implementation + let lbsRef = toLazyByteString $ fold + [string8 before, b, string8 between, b, string8 after] + -- report + let msg = unlines + [ "task: " ++ show args + , "via file: " ++ show lbs + , "direct : " ++ show lbsRef + -- , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) + ] + success = lbs == lbsRef + unless success (error msg) + return success + +testWriteFile :: TestTree +testWriteFile = + testProperty "writeFile" testRecipe + where + testRecipe :: Recipe -> Property + testRecipe recipe = + ioProperty $ do + (tempFile, tempH) <- openTempFile "." "test-builder-writeFile.tmp" + hClose tempH + let b = fst $ recipeComponents recipe + writeFile tempFile b + lbs <- L.readFile tempFile + _ <- evaluate (L.length $ lbs) + removeFile tempFile + let lbsRef = toLazyByteString b + -- report + let msg = + unlines + [ "recipe: " ++ show recipe + , "via file: " ++ show lbs + , "direct : " ++ show lbsRef + ] + success = lbs == lbsRef + unless success (error msg) + return success + +testStimes :: TestTree +testStimes = testProperty "stimes" $ + \(Sqrt (NonNegative n)) (Sqrt x) -> + stimes (n :: Int) x === toLazyByteString (stimes n (lazyByteString x)) + +removeFile :: String -> IO () +removeFile fn = void $ withCString fn c_unlink + +-- Recipes with which to test the builder functions +--------------------------------------------------- + +data Mode = + Threshold Int + | Insert + | Copy + | Smart + | Hex + deriving( Eq, Ord, Show ) + +data Action = + SBS Mode S.ByteString + | LBS Mode L.ByteString + | ShBS Sh.ShortByteString + | W8 Word8 + | W8S [Word8] + | String String + | FDec Float + | DDec Double + | Flush + | EnsureFree Word + | ModState Int + deriving( Eq, Ord, Show ) + +data Strategy = Safe | Untrimmed + deriving( Eq, Ord, Show ) + +data Recipe = Recipe Strategy Int Int L.ByteString [Action] + deriving( Eq, Ord, Show ) + +newtype DList a = DList ([a] -> [a]) + +instance Semigroup (DList a) where + DList f <> DList g = DList (f . g) + +instance Monoid (DList a) where + mempty = DList id + mappend = (<>) + +fromDList :: DList a -> [a] +fromDList (DList f) = f [] + +toDList :: [a] -> DList a +toDList xs = DList (xs <>) + +renderRecipe :: Recipe -> [Word8] +renderRecipe (Recipe _ firstSize _ cont as) = + fromDList $ evalState (execWriterT (traverse_ renderAction as)) firstSize <> renderLBS cont + where + renderAction :: Monad m => Action -> WriterT (DList Word8) (StateT Int m) () + renderAction (SBS Hex bs) = tell $ foldMap hexWord8 $ S.unpack bs + renderAction (SBS _ bs) = tell $ toDList $ S.unpack bs + renderAction (LBS Hex lbs) = tell $ foldMap hexWord8 $ L.unpack lbs + renderAction (LBS _ lbs) = tell $ renderLBS lbs + renderAction (ShBS sbs) = tell $ toDList $ Sh.unpack sbs + renderAction (W8 w) = tell $ toDList [w] + renderAction (W8S ws) = tell $ toDList ws + renderAction (String cs) = tell $ foldMap (toDList . charUtf8_list) cs + renderAction Flush = tell $ mempty + renderAction (EnsureFree _) = tell $ mempty + renderAction (FDec f) = tell $ toDList $ encodeASCII $ show f + renderAction (DDec d) = tell $ toDList $ encodeASCII $ show d + renderAction (ModState i) = do + s <- lift get + tell (toDList $ encodeASCII $ show s) + lift $ put (s - i) + + renderLBS = toDList . L.unpack + hexWord8 = toDList . wordHexFixed_list + +buildAction :: Action -> StateT Int Put () +buildAction (SBS Hex bs) = lift $ putBuilder $ byteStringHex bs +buildAction (SBS Smart bs) = lift $ putBuilder $ byteString bs +buildAction (SBS Copy bs) = lift $ putBuilder $ byteStringCopy bs +buildAction (SBS Insert bs) = lift $ putBuilder $ byteStringInsert bs +buildAction (SBS (Threshold i) bs) = lift $ putBuilder $ byteStringThreshold i bs +buildAction (LBS Hex lbs) = lift $ putBuilder $ lazyByteStringHex lbs +buildAction (LBS Smart lbs) = lift $ putBuilder $ lazyByteString lbs +buildAction (LBS Copy lbs) = lift $ putBuilder $ lazyByteStringCopy lbs +buildAction (LBS Insert lbs) = lift $ putBuilder $ lazyByteStringInsert lbs +buildAction (LBS (Threshold i) lbs) = lift $ putBuilder $ lazyByteStringThreshold i lbs +buildAction (ShBS sbs) = lift $ putBuilder $ shortByteString sbs +buildAction (W8 w) = lift $ putBuilder $ word8 w +buildAction (W8S ws) = lift $ putBuilder $ BP.primMapListFixed BP.word8 ws +buildAction (String cs) = lift $ putBuilder $ stringUtf8 cs +buildAction (FDec f) = lift $ putBuilder $ floatDec f +buildAction (DDec d) = lift $ putBuilder $ doubleDec d +buildAction Flush = lift $ putBuilder $ flush +buildAction (EnsureFree minFree) = lift $ putBuilder $ ensureFree $ fromIntegral minFree +buildAction (ModState i) = do + s <- get + lift $ putBuilder $ intDec s + put (s - i) + +buildRecipe :: Recipe -> [Word8] +buildRecipe recipe = + L.unpack $ toLBS b + where + (b, toLBS) = recipeComponents recipe + + +recipeComponents :: Recipe -> (Builder, Builder -> L.ByteString) +recipeComponents (Recipe how firstSize otherSize cont as) = + (b, toLBS) + where + toLBS = toLazyByteStringWith (strategy how firstSize otherSize) cont + where + strategy Safe = safeStrategy + strategy Untrimmed = untrimmedStrategy + + b = fromPut $ evalStateT (traverse_ buildAction as) firstSize + + +-- 'Arbitary' instances +----------------------- + +instance Arbitrary Mode where + arbitrary = oneof + [Threshold <$> arbitrary, pure Smart, pure Insert, pure Copy, pure Hex] + + shrink (Threshold i) = Threshold <$> shrink i + shrink _ = [] + +instance Arbitrary Action where + arbitrary = oneof + [ SBS <$> arbitrary <*> arbitrary + , LBS <$> arbitrary <*> arbitrary + , ShBS . Sh.toShort <$> arbitrary + , W8 <$> arbitrary + , W8S <$> listOf arbitrary + -- ensure that larger character codes are also tested + , String . getUnicodeString <$> arbitrary + , pure Flush + -- never request more than 64kb free space + , (EnsureFree . (`mod` 0xffff)) <$> arbitrary + , FDec <$> arbitrary + , DDec <$> arbitrary + , ModState <$> arbitrary + ] + where + + shrink (SBS m bs) = + (SBS <$> shrink m <*> pure bs) <|> + (SBS <$> pure m <*> shrink bs) + shrink (LBS m lbs) = + (LBS <$> shrink m <*> pure lbs) <|> + (LBS <$> pure m <*> shrink lbs) + shrink (ShBS sbs) = + ShBS . Sh.toShort <$> shrink (Sh.fromShort sbs) + shrink (W8 w) = W8 <$> shrink w + shrink (W8S ws) = W8S <$> shrink ws + shrink (String cs) = String <$> shrink cs + shrink Flush = [] + shrink (EnsureFree i) = EnsureFree <$> shrink i + shrink (FDec f) = FDec <$> shrink f + shrink (DDec d) = DDec <$> shrink d + shrink (ModState i) = ModState <$> shrink i + +instance Arbitrary Strategy where + arbitrary = elements [Safe, Untrimmed] + shrink _ = [] + +instance Arbitrary Recipe where + arbitrary = + Recipe <$> arbitrary + <*> ((`mod` 33333) <$> arbitrary) -- bound max chunk-sizes + <*> ((`mod` 33337) <$> arbitrary) + <*> arbitrary + <*> listOf arbitrary + + -- shrinking the actions first is desirable + shrink (Recipe a b c d e) = asum + [ (\x -> Recipe a b c d x) <$> shrink e + , (\x -> Recipe a b c x e) <$> shrink d + , (\x -> Recipe a b x d e) <$> shrink c + , (\x -> Recipe a x c d e) <$> shrink b + , (\x -> Recipe x b c d e) <$> shrink a + ] + + +------------------------------------------------------------------------------ +-- Creating Builders from basic encodings +------------------------------------------------------------------------------ + +testsEncodingToBuilder :: [TestTree] +testsEncodingToBuilder = + [ test_encodeUnfoldrF + , test_encodeUnfoldrB + ] + + +-- Unfoldr fused with encoding +------------------------------ + +test_encodeUnfoldrF :: TestTree +test_encodeUnfoldrF = + compareImpls "encodeUnfoldrF word8" id encode + where + toLBS = toLazyByteStringWith (safeStrategy 23 101) L.empty + encode = + L.unpack . toLBS . BP.primUnfoldrFixed BP.word8 go + where + go [] = Nothing + go (w:ws) = Just (w, ws) + + +test_encodeUnfoldrB :: TestTree +test_encodeUnfoldrB = + compareImpls "encodeUnfoldrB charUtf8" (foldMap charUtf8_list) encode + where + toLBS = toLazyByteStringWith (safeStrategy 23 101) L.empty + encode = + L.unpack . toLBS . BP.primUnfoldrBounded BP.charUtf8 go + where + go [] = Nothing + go (c:cs) = Just (c, cs) + + +------------------------------------------------------------------------------ +-- Testing the Put monad +------------------------------------------------------------------------------ + +testPut :: TestTree +testPut = testGroup "Put monad" + [ testLaw "identity" (\v -> (pure id <*> putInt v) `eqPut` (putInt v)) + + , testLaw "composition" $ \(u, v, w) -> + (pure (.) <*> minusInt u <*> minusInt v <*> putInt w) `eqPut` + (minusInt u <*> (minusInt v <*> putInt w)) + + , testLaw "homomorphism" $ \(f, x) -> + (pure (f -) <*> pure x) `eqPut` (pure (f - x)) + + , testLaw "interchange" $ \(u, y) -> + (minusInt u <*> pure y) `eqPut` (pure ($ y) <*> minusInt u) + + , testLaw "ignore left value" $ \(u, v) -> + (putInt u *> putInt v) `eqPut` (pure (const id) <*> putInt u <*> putInt v) + + , testLaw "ignore right value" $ \(u, v) -> + (putInt u <* putInt v) `eqPut` (pure const <*> putInt u <*> putInt v) + + , testLaw "functor" $ \(f, x) -> + (fmap (f -) (putInt x)) `eqPut` (pure (f -) <*> putInt x) + + ] + where + putInt i = putBuilder (integerDec i) >> return i + minusInt i = (-) <$> putInt i + run p = toLazyByteString $ fromPut (do i <- p; _ <- putInt i; return ()) + eqPut p1 p2 = (run p1, run p2) + + testLaw name f = compareImpls name (fst . f) (snd . f) + + +------------------------------------------------------------------------------ +-- Testing the Driver <-> Builder protocol +------------------------------------------------------------------------------ + +-- | Ensure that there are at least 'n' free bytes for the following 'Builder'. +{-# INLINE ensureFree #-} +ensureFree :: Int -> Builder +ensureFree minFree = + BI.builder step + where + step k br@(BI.BufferRange op ope) + | ope `minusPtr` op < minFree = return $ BI.bufferFull minFree op next + | otherwise = k br + where + next br'@(BI.BufferRange op' ope') + | freeSpace < minFree = + error $ "ensureFree: requested " ++ show minFree ++ " bytes, " ++ + "but got only " ++ show freeSpace ++ " bytes" + | otherwise = k br' + where + freeSpace = ope' `minusPtr` op' + + +------------------------------------------------------------------------------ +-- Testing the Builder runner +------------------------------------------------------------------------------ + +testRunBuilder :: TestTree +testRunBuilder = + testProperty "runBuilder" prop + where + prop actions = + ioProperty $ do + let (builder, _) = recipeComponents recipe + expected = renderRecipe recipe + actual <- bufferWriterOutput (runBuilder builder) + return (S.unpack actual == expected) + where + recipe = Recipe Safe 0 0 L.empty actions + +bufferWriterOutput :: BufferWriter -> IO S.ByteString +bufferWriterOutput bwrite0 = do + let len0 = 8 + buf <- S.mallocByteString len0 + bss <- go [] buf len0 bwrite0 + return (S.concat (reverse bss)) + where + go :: [S.ByteString] -> ForeignPtr Word8 -> Int -> BufferWriter -> IO [S.ByteString] + go bss !buf !len bwrite = do + (wc, next) <- withForeignPtr buf $ \ptr -> bwrite ptr len + bs <- getBuffer buf wc + case next of + Done -> return (bs:bss) + More m bwrite' | m <= len -> go (bs:bss) buf len bwrite' + | otherwise -> do let len' = m + buf' <- S.mallocByteString len' + go (bs:bss) buf' len' bwrite' + Chunk c bwrite' -> go (c:bs:bss) buf len bwrite' + + getBuffer :: ForeignPtr Word8 -> Int -> IO S.ByteString + getBuffer buf len = withForeignPtr buf $ \ptr -> + S.packCStringLen (castPtr ptr, len) + + +------------------------------------------------------------------------------ +-- Testing the pre-defined builders +------------------------------------------------------------------------------ + +testBuilderConstr :: (Arbitrary a, Show a) + => TestName -> (a -> [Word8]) -> (a -> Builder) -> TestTree +testBuilderConstr name ref mkBuilder = + testProperty name check + where + check = int64OK $ \x -> + forAllShrink genPaddingAmount shrink $ \paddingAmount -> let + -- use padding to make sure we test at unaligned positions + ws = ref x + b1 = mkBuilder x + b2 = byteStringCopy (S.take paddingAmount padBuf) <> b1 <> b1 + in (replicate paddingAmount (S.c2w ' ') ++ ws ++ ws) === + (L.unpack $ toLazyByteString b2) + + maxPaddingAmount = 15 + padBuf = S.replicate maxPaddingAmount (S.c2w ' ') + genPaddingAmount = choose (0, maxPaddingAmount) + + +testsBinary :: [TestTree] +testsBinary = + [ testBuilderConstr "word8" bigEndian_list word8 + , testBuilderConstr "int8" bigEndian_list int8 + + -- big-endian + , testBuilderConstr "int16BE" bigEndian_list int16BE + , testBuilderConstr "int32BE" bigEndian_list int32BE + , testBuilderConstr "int64BE" bigEndian_list int64BE + + , testBuilderConstr "word16BE" bigEndian_list word16BE + , testBuilderConstr "word32BE" bigEndian_list word32BE + , testBuilderConstr "word64BE" bigEndian_list word64BE + + , testBuilderConstr "floatLE" (float_list littleEndian_list) floatLE + , testBuilderConstr "doubleLE" (double_list littleEndian_list) doubleLE + + -- little-endian + , testBuilderConstr "int16LE" littleEndian_list int16LE + , testBuilderConstr "int32LE" littleEndian_list int32LE + , testBuilderConstr "int64LE" littleEndian_list int64LE + + , testBuilderConstr "word16LE" littleEndian_list word16LE + , testBuilderConstr "word32LE" littleEndian_list word32LE + , testBuilderConstr "word64LE" littleEndian_list word64LE + + , testBuilderConstr "floatBE" (float_list bigEndian_list) floatBE + , testBuilderConstr "doubleBE" (double_list bigEndian_list) doubleBE + + -- host dependent + , testBuilderConstr "int16Host" hostEndian_list int16Host + , testBuilderConstr "int32Host" hostEndian_list int32Host + , testBuilderConstr "int64Host" hostEndian_list int64Host + , testBuilderConstr "intHost" hostEndian_list intHost + + , testBuilderConstr "word16Host" hostEndian_list word16Host + , testBuilderConstr "word32Host" hostEndian_list word32Host + , testBuilderConstr "word64Host" hostEndian_list word64Host + , testBuilderConstr "wordHost" hostEndian_list wordHost + + , testBuilderConstr "floatHost" (float_list hostEndian_list) floatHost + , testBuilderConstr "doubleHost" (double_list hostEndian_list) doubleHost + ] + +testsASCII :: [TestTree] +testsASCII = + [ testBuilderConstr "char7" char7_list char7 + , testBuilderConstr "string7" (foldMap char7_list) string7 + + , testBuilderConstr "int8Dec" dec_list int8Dec + , testBuilderConstr "int16Dec" dec_list int16Dec + , testBuilderConstr "int32Dec" dec_list int32Dec + , testBuilderConstr "int64Dec" dec_list int64Dec + , testBuilderConstr "intDec" dec_list intDec + + , testBuilderConstr "word8Dec" dec_list word8Dec + , testBuilderConstr "word16Dec" dec_list word16Dec + , testBuilderConstr "word32Dec" dec_list word32Dec + , testBuilderConstr "word64Dec" dec_list word64Dec + , testBuilderConstr "wordDec" dec_list wordDec + + , testBuilderConstr "integerDec" (dec_list . enlarge) (integerDec . enlarge) + , testBuilderConstr "floatDec" dec_list floatDec + , testBuilderConstr "doubleDec" dec_list doubleDec + + , testBuilderConstr "word8Hex" hex_list word8Hex + , testBuilderConstr "word16Hex" hex_list word16Hex + , testBuilderConstr "word32Hex" hex_list word32Hex + , testBuilderConstr "word64Hex" hex_list word64Hex + , testBuilderConstr "wordHex" hex_list wordHex + + , testBuilderConstr "word8HexFixed" wordHexFixed_list word8HexFixed + , testBuilderConstr "word16HexFixed" wordHexFixed_list word16HexFixed + , testBuilderConstr "word32HexFixed" wordHexFixed_list word32HexFixed + , testBuilderConstr "word64HexFixed" wordHexFixed_list word64HexFixed + + , testBuilderConstr "int8HexFixed" int8HexFixed_list int8HexFixed + , testBuilderConstr "int16HexFixed" int16HexFixed_list int16HexFixed + , testBuilderConstr "int32HexFixed" int32HexFixed_list int32HexFixed + , testBuilderConstr "int64HexFixed" int64HexFixed_list int64HexFixed + + , testBuilderConstr "floatHexFixed" floatHexFixed_list floatHexFixed + , testBuilderConstr "doubleHexFixed" doubleHexFixed_list doubleHexFixed + ] + where + enlarge (n, e) = n ^ (abs (e `mod` (50 :: Integer))) + +testsFloating :: [TestTree] +testsFloating = + [ testMatches "f2sBasic" floatDec show + [ ( 0.0 , "0.0" ) + , ( (-0.0) , "-0.0" ) + , ( 1.0 , "1.0" ) + , ( (-1.0) , "-1.0" ) + , ( (0/0) , "NaN" ) + , ( (1/0) , "Infinity" ) + , ( (-1/0) , "-Infinity" ) + ] + , testMatches "f2sSubnormal" floatDec show + [ ( 1.1754944e-38 , "1.1754944e-38" ) + ] + , testMatches "f2sMinAndMax" floatDec show + [ ( coerceWord32ToFloat 0x7f7fffff , "3.4028235e38" ) + , ( coerceWord32ToFloat 0x00000001 , "1.0e-45" ) + ] + , testMatches "f2sBoundaryRound" floatDec show + [ ( 3.355445e7 , "3.3554448e7" ) + , ( 8.999999e9 , "8.999999e9" ) + , ( 3.4366717e10 , "3.4366718e10" ) + ] + , testMatches "f2sExactValueRound" floatDec show + [ ( 3.0540412e5 , "305404.13" ) + , ( 8.0990312e3 , "8099.0313" ) + ] + , testMatches "f2sTrailingZeros" floatDec show + -- Pattern for the first test: 00111001100000000000000000000000 + [ ( 2.4414062e-4 , "2.4414063e-4" ) + , ( 2.4414062e-3 , "2.4414063e-3" ) + , ( 4.3945312e-3 , "4.3945313e-3" ) + , ( 6.3476562e-3 , "6.3476563e-3" ) + ] + , testMatches "f2sRegression" floatDec show + [ ( 4.7223665e21 , "4.7223665e21" ) + , ( 8388608.0 , "8388608.0" ) + , ( 1.6777216e7 , "1.6777216e7" ) + , ( 3.3554436e7 , "3.3554436e7" ) + , ( 6.7131496e7 , "6.7131496e7" ) + , ( 1.9310392e-38 , "1.9310392e-38" ) + , ( (-2.47e-43) , "-2.47e-43" ) + , ( 1.993244e-38 , "1.993244e-38" ) + , ( 4103.9003 , "4103.9004" ) + , ( 5.3399997e9 , "5.3399997e9" ) + , ( 6.0898e-39 , "6.0898e-39" ) + , ( 0.0010310042 , "1.0310042e-3" ) + , ( 2.8823261e17 , "2.882326e17" ) + , ( 7.0385309e-26 , "7.038531e-26" ) + , ( 9.2234038e17 , "9.223404e17" ) + , ( 6.7108872e7 , "6.710887e7" ) + , ( 1.0e-44 , "1.0e-44" ) + , ( 2.816025e14 , "2.816025e14" ) + , ( 9.223372e18 , "9.223372e18" ) + , ( 1.5846085e29 , "1.5846086e29" ) + , ( 1.1811161e19 , "1.1811161e19" ) + , ( 5.368709e18 , "5.368709e18" ) + , ( 4.6143165e18 , "4.6143166e18" ) + , ( 0.007812537 , "7.812537e-3" ) + , ( 1.4e-45 , "1.0e-45" ) + , ( 1.18697724e20 , "1.18697725e20" ) + , ( 1.00014165e-36 , "1.00014165e-36" ) + , ( 200.0 , "200.0" ) + , ( 3.3554432e7 , "3.3554432e7" ) + , ( 2.0019531 , "2.0019531" ) + , ( 2.001953 , "2.001953" ) + ] + , testExpected "f2sScientific" (formatFloat scientific) + [ ( 0.0 , "0.0e0" ) + , ( 8388608.0 , "8.388608e6" ) + , ( 1.6777216e7 , "1.6777216e7" ) + , ( 3.3554436e7 , "3.3554436e7" ) + , ( 6.7131496e7 , "6.7131496e7" ) + , ( 1.9310392e-38 , "1.9310392e-38" ) + , ( (-2.47e-43) , "-2.47e-43" ) + , ( 1.993244e-38 , "1.993244e-38" ) + , ( 4103.9003 , "4.1039004e3" ) + , ( 0.0010310042 , "1.0310042e-3" ) + , ( 0.007812537 , "7.812537e-3" ) + , ( 200.0 , "2.0e2" ) + , ( 2.0019531 , "2.0019531e0" ) + , ( 2.001953 , "2.001953e0" ) + ] + , testMatches "f2sLooksLikePowerOf5" floatDec show + [ ( coerceWord32ToFloat 0x5D1502F9 , "6.7108864e17" ) + , ( coerceWord32ToFloat 0x5D9502F9 , "1.3421773e18" ) + , ( coerceWord32ToFloat 0x5e1502F9 , "2.6843546e18" ) + ] + , testMatches "f2sOutputLength" floatDec show + [ ( 1.0 , "1.0" ) + , ( 1.2 , "1.2" ) + , ( 1.23 , "1.23" ) + , ( 1.234 , "1.234" ) + , ( 1.2345 , "1.2345" ) + , ( 1.23456 , "1.23456" ) + , ( 1.234567 , "1.234567" ) + , ( 1.2345678 , "1.2345678" ) + , ( 1.23456735e-36 , "1.23456735e-36" ) + ] + , testMatches "d2sBasic" doubleDec show + [ ( 0.0 , "0.0" ) + , ( (-0.0) , "-0.0" ) + , ( 1.0 , "1.0" ) + , ( (-1.0) , "-1.0" ) + , ( (0/0) , "NaN" ) + , ( (1/0) , "Infinity" ) + , ( (-1/0) , "-Infinity" ) + ] + , testMatches "d2sSubnormal" doubleDec show + [ ( 2.2250738585072014e-308 , "2.2250738585072014e-308" ) + ] + , testMatches "d2sMinAndMax" doubleDec show + [ ( (coerceWord64ToDouble 0x7fefffffffffffff) , "1.7976931348623157e308" ) + , ( (coerceWord64ToDouble 0x0000000000000001) , "5.0e-324" ) + ] + , testMatches "d2sTrailingZeros" doubleDec show + [ ( 2.98023223876953125e-8 , "2.9802322387695313e-8" ) + ] + , testMatches "d2sRegression" doubleDec show + [ ( (-2.109808898695963e16) , "-2.1098088986959632e16" ) + , ( 4.940656e-318 , "4.940656e-318" ) + , ( 1.18575755e-316 , "1.18575755e-316" ) + , ( 2.989102097996e-312 , "2.989102097996e-312" ) + , ( 9.0608011534336e15 , "9.0608011534336e15" ) + , ( 4.708356024711512e18 , "4.708356024711512e18" ) + , ( 9.409340012568248e18 , "9.409340012568248e18" ) + , ( 1.2345678 , "1.2345678" ) + , ( 1.9430376160308388e16 , "1.9430376160308388e16" ) + , ( (-6.9741824662760956e19), "-6.9741824662760956e19" ) + , ( 4.3816050601147837e18 , "4.3816050601147837e18" ) + ] + , testExpected "d2sScientific" (formatDouble scientific) + [ ( 0.0 , "0.0e0" ) + , ( 1.2345678 , "1.2345678e0" ) + , ( 4.294967294 , "4.294967294e0" ) + , ( 4.294967295 , "4.294967295e0" ) + ] + , testProperty "d2sStandard" $ conjoin + [ singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.345 , "12.34" ) + , singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0050 , "0.00" ) + , singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0051 , "0.01" ) + , singleMatches (formatDouble (standard 5)) (flip (showFFloat (Just 5)) []) ( 12.345 , "12.34500" ) + ] + , testMatches "d2sLooksLikePowerOf5" doubleDec show + [ ( (coerceWord64ToDouble 0x4830F0CF064DD592) , "5.764607523034235e39" ) + , ( (coerceWord64ToDouble 0x4840F0CF064DD592) , "1.152921504606847e40" ) + , ( (coerceWord64ToDouble 0x4850F0CF064DD592) , "2.305843009213694e40" ) + , ( (coerceWord64ToDouble 0x4400000000000004) , "3.689348814741914e19" ) + + -- here v- is a power of 5 but since we don't accept bounds there is no + -- interesting trailing behavior + , ( (coerceWord64ToDouble 0x440000000000301d) , "3.6893488147520004e19" ) + ] + , testMatches "d2sOutputLength" doubleDec show + [ ( 1 , "1.0" ) + , ( 1.2 , "1.2" ) + , ( 1.23 , "1.23" ) + , ( 1.234 , "1.234" ) + , ( 1.2345 , "1.2345" ) + , ( 1.23456 , "1.23456" ) + , ( 1.234567 , "1.234567" ) + , ( 1.2345678 , "1.2345678" ) + , ( 1.23456789 , "1.23456789" ) + , ( 1.234567895 , "1.234567895" ) + , ( 1.2345678901 , "1.2345678901" ) + , ( 1.23456789012 , "1.23456789012" ) + , ( 1.234567890123 , "1.234567890123" ) + , ( 1.2345678901234 , "1.2345678901234" ) + , ( 1.23456789012345 , "1.23456789012345" ) + , ( 1.234567890123456 , "1.234567890123456" ) + , ( 1.2345678901234567 , "1.2345678901234567" ) + + -- Test 32-bit chunking + , ( 4.294967294 , "4.294967294" ) + , ( 4.294967295 , "4.294967295" ) + , ( 4.294967296 , "4.294967296" ) + , ( 4.294967297 , "4.294967297" ) + , ( 4.294967298 , "4.294967298" ) + ] + , testMatches "d2sMinMaxShift" doubleDec show + [ ( (ieeeParts2Double False 4 0) , "1.7800590868057611e-307" ) + -- 32-bit opt-size=0: 49 <= dist <= 49 + -- 32-bit opt-size=1: 28 <= dist <= 49 + -- 64-bit opt-size=0: 50 <= dist <= 50 + -- 64-bit opt-size=1: 28 <= dist <= 50 + , ( (ieeeParts2Double False 6 maxMantissa) , "2.8480945388892175e-306" ) + -- 32-bit opt-size=0: 52 <= dist <= 53 + -- 32-bit opt-size=1: 2 <= dist <= 53 + -- 64-bit opt-size=0: 53 <= dist <= 53 + -- 64-bit opt-size=1: 2 <= dist <= 53 + , ( (ieeeParts2Double False 41 0) , "2.446494580089078e-296" ) + -- 32-bit opt-size=0: 52 <= dist <= 52 + -- 32-bit opt-size=1: 2 <= dist <= 52 + -- 64-bit opt-size=0: 53 <= dist <= 53 + -- 64-bit opt-size=1: 2 <= dist <= 53 + , ( (ieeeParts2Double False 40 maxMantissa) , "4.8929891601781557e-296" ) + -- 32-bit opt-size=0: 57 <= dist <= 58 + -- 32-bit opt-size=1: 57 <= dist <= 58 + -- 64-bit opt-size=0: 58 <= dist <= 58 + -- 64-bit opt-size=1: 58 <= dist <= 58 + , ( (ieeeParts2Double False 1077 0) , "1.8014398509481984e16" ) + -- 32-bit opt-size=0: 57 <= dist <= 57 + -- 32-bit opt-size=1: 57 <= dist <= 57 + -- 64-bit opt-size=0: 58 <= dist <= 58 + -- 64-bit opt-size=1: 58 <= dist <= 58 + , ( (ieeeParts2Double False 1076 maxMantissa) , "3.6028797018963964e16" ) + -- 32-bit opt-size=0: 51 <= dist <= 52 + -- 32-bit opt-size=1: 51 <= dist <= 59 + -- 64-bit opt-size=0: 52 <= dist <= 52 + -- 64-bit opt-size=1: 52 <= dist <= 59 + , ( (ieeeParts2Double False 307 0) , "2.900835519859558e-216" ) + -- 32-bit opt-size=0: 51 <= dist <= 51 + -- 32-bit opt-size=1: 51 <= dist <= 59 + -- 64-bit opt-size=0: 52 <= dist <= 52 + -- 64-bit opt-size=1: 52 <= dist <= 59 + , ( (ieeeParts2Double False 306 maxMantissa) , "5.801671039719115e-216" ) + -- 32-bit opt-size=0: 49 <= dist <= 49 + -- 32-bit opt-size=1: 44 <= dist <= 49 + -- 64-bit opt-size=0: 50 <= dist <= 50 + -- 64-bit opt-size=1: 44 <= dist <= 50 + , ( (ieeeParts2Double False 934 0x000FA7161A4D6e0C) , "3.196104012172126e-27" ) + ] + , testMatches "d2sSmallIntegers" doubleDec show + [ ( 9007199254740991.0 , "9.007199254740991e15" ) + , ( 9007199254740992.0 , "9.007199254740992e15" ) + + , ( 1.0e+0 , "1.0" ) + , ( 1.2e+1 , "12.0" ) + , ( 1.23e+2 , "123.0" ) + , ( 1.234e+3 , "1234.0" ) + , ( 1.2345e+4 , "12345.0" ) + , ( 1.23456e+5 , "123456.0" ) + , ( 1.234567e+6 , "1234567.0" ) + , ( 1.2345678e+7 , "1.2345678e7" ) + , ( 1.23456789e+8 , "1.23456789e8" ) + , ( 1.23456789e+9 , "1.23456789e9" ) + , ( 1.234567895e+9 , "1.234567895e9" ) + , ( 1.2345678901e+10 , "1.2345678901e10" ) + , ( 1.23456789012e+11 , "1.23456789012e11" ) + , ( 1.234567890123e+12 , "1.234567890123e12" ) + , ( 1.2345678901234e+13 , "1.2345678901234e13" ) + , ( 1.23456789012345e+14 , "1.23456789012345e14" ) + , ( 1.234567890123456e+15 , "1.234567890123456e15" ) + + -- 10^i + , ( 1.0e+0 , "1.0" ) + , ( 1.0e+1 , "10.0" ) + , ( 1.0e+2 , "100.0" ) + , ( 1.0e+3 , "1000.0" ) + , ( 1.0e+4 , "10000.0" ) + , ( 1.0e+5 , "100000.0" ) + , ( 1.0e+6 , "1000000.0" ) + , ( 1.0e+7 , "1.0e7" ) + , ( 1.0e+8 , "1.0e8" ) + , ( 1.0e+9 , "1.0e9" ) + , ( 1.0e+10 , "1.0e10" ) + , ( 1.0e+11 , "1.0e11" ) + , ( 1.0e+12 , "1.0e12" ) + , ( 1.0e+13 , "1.0e13" ) + , ( 1.0e+14 , "1.0e14" ) + , ( 1.0e+15 , "1.0e15" ) + + -- 10^15 + 10^i + , ( (1.0e+15 + 1.0e+0) , "1.000000000000001e15" ) + , ( (1.0e+15 + 1.0e+1) , "1.00000000000001e15" ) + , ( (1.0e+15 + 1.0e+2) , "1.0000000000001e15" ) + , ( (1.0e+15 + 1.0e+3) , "1.000000000001e15" ) + , ( (1.0e+15 + 1.0e+4) , "1.00000000001e15" ) + , ( (1.0e+15 + 1.0e+5) , "1.0000000001e15" ) + , ( (1.0e+15 + 1.0e+6) , "1.000000001e15" ) + , ( (1.0e+15 + 1.0e+7) , "1.00000001e15" ) + , ( (1.0e+15 + 1.0e+8) , "1.0000001e15" ) + , ( (1.0e+15 + 1.0e+9) , "1.000001e15" ) + , ( (1.0e+15 + 1.0e+10) , "1.00001e15" ) + , ( (1.0e+15 + 1.0e+11) , "1.0001e15" ) + , ( (1.0e+15 + 1.0e+12) , "1.001e15" ) + , ( (1.0e+15 + 1.0e+13) , "1.01e15" ) + , ( (1.0e+15 + 1.0e+14) , "1.1e15" ) + + -- Largest power of 2 <= 10^(i+1) + , ( 8.0 , "8.0" ) + , ( 64.0 , "64.0" ) + , ( 512.0 , "512.0" ) + , ( 8192.0 , "8192.0" ) + , ( 65536.0 , "65536.0" ) + , ( 524288.0 , "524288.0" ) + , ( 8388608.0 , "8388608.0" ) + , ( 67108864.0 , "6.7108864e7" ) + , ( 536870912.0 , "5.36870912e8" ) + , ( 8589934592.0 , "8.589934592e9" ) + , ( 68719476736.0 , "6.8719476736e10" ) + , ( 549755813888.0 , "5.49755813888e11" ) + , ( 8796093022208.0 , "8.796093022208e12" ) + , ( 70368744177664.0 , "7.0368744177664e13" ) + , ( 562949953421312.0 , "5.62949953421312e14" ) + , ( 9007199254740992.0 , "9.007199254740992e15" ) + + -- 1000 * (Largest power of 2 <= 10^(i+1)) + , ( 8.0e+3 , "8000.0" ) + , ( 64.0e+3 , "64000.0" ) + , ( 512.0e+3 , "512000.0" ) + , ( 8192.0e+3 , "8192000.0" ) + , ( 65536.0e+3 , "6.5536e7" ) + , ( 524288.0e+3 , "5.24288e8" ) + , ( 8388608.0e+3 , "8.388608e9" ) + , ( 67108864.0e+3 , "6.7108864e10" ) + , ( 536870912.0e+3 , "5.36870912e11" ) + , ( 8589934592.0e+3 , "8.589934592e12" ) + , ( 68719476736.0e+3 , "6.8719476736e13" ) + , ( 549755813888.0e+3 , "5.49755813888e14" ) + , ( 8796093022208.0e+3 , "8.796093022208e15" ) + ] + , testMatches "f2sPowersOf10" floatDec show $ + fmap asShowRef [read ("1.0e" ++ show x) :: Float | x <- [-46..39 :: Int]] + , testMatches "d2sPowersOf10" doubleDec show $ + fmap asShowRef [read ("1.0e" ++ show x) :: Double | x <- [-324..309 :: Int]] + ] + where + testExpected :: TestName -> (a -> Builder) -> [(a, String)] -> TestTree + testExpected name dec lst = testProperty name . conjoin $ + fmap (\(x, ref) -> L.unpack (toLazyByteString (dec x)) === encodeASCII ref) lst + + singleMatches :: (a -> Builder) -> (a -> String) -> (a, String) -> Property + singleMatches dec refdec (x, ref) = L.unpack (toLazyByteString (dec x)) === encodeASCII (refdec x) .&&. refdec x === ref + + testMatches :: TestName -> (a -> Builder) -> (a -> String) -> [(a, String)] -> TestTree + testMatches name dec refdec lst = testProperty name . conjoin $ fmap (singleMatches dec refdec) lst + + maxMantissa = (1 `shiftL` 53) - 1 :: Word64 + + ieeeParts2Double :: Bool -> Int -> Word64 -> Double + ieeeParts2Double sign expo mantissa = + coerceWord64ToDouble $ (fromIntegral (fromEnum sign) `shiftL` 63) .|. (fromIntegral expo `shiftL` 52) .|. mantissa + + asShowRef x = (x, show x) + +testsChar8 :: [TestTree] +testsChar8 = + [ testBuilderConstr "charChar8" char8_list char8 + , testBuilderConstr "stringChar8" (foldMap char8_list) string8 + ] + +testsUtf8 :: [TestTree] +testsUtf8 = + [ testBuilderConstr "charUtf8" charUtf8_list charUtf8 + , testBuilderConstr "stringUtf8" (foldMap charUtf8_list) stringUtf8 + ] + +testLaziness :: TestTree +testLaziness = testGroup "Builder laziness" + [ testProperty "byteString" $ mapSize (+ 10) $ + \bs (Positive chunkSize) -> + let strategy = safeStrategy chunkSize chunkSize + lbs = toLazyByteStringWith strategy L.empty + (byteString bs <> tooStrictErr) + in (S.length bs > max chunkSize 8) ==> L.head lbs == S.head bs + , testProperty "byteStringCopy" $ mapSize (+ 10) $ + \bs (Positive chunkSize) -> + let strategy = safeStrategy chunkSize chunkSize + lbs = toLazyByteStringWith strategy L.empty + (byteStringCopy bs <> tooStrictErr) + in (S.length bs > max chunkSize 8) ==> L.head lbs == S.head bs + , testProperty "byteStringInsert" $ mapSize (+ 10) $ + \bs (Positive chunkSize) -> + let strategy = safeStrategy chunkSize chunkSize + lbs = toLazyByteStringWith strategy L.empty + (byteStringInsert bs <> tooStrictErr) + in L.take (fromIntegral @Int @Int64 (S.length bs)) lbs + == L.fromStrict bs + , testProperty "lazyByteString" $ mapSize (+ 10) $ + \bs (Positive chunkSize) -> + let strategy = safeStrategy chunkSize chunkSize + lbs = toLazyByteStringWith strategy L.empty + (lazyByteString bs <> tooStrictErr) + in (L.length bs > fromIntegral @Int @Int64 (max chunkSize 8)) + ==> L.head lbs == L.head bs + , testProperty "shortByteString" $ mapSize (+ 10) $ + \bs (Positive chunkSize) -> + let strategy = safeStrategy chunkSize chunkSize + lbs = toLazyByteStringWith strategy L.empty + (shortByteString bs <> tooStrictErr) + in (Sh.length bs > max chunkSize 8) ==> L.head lbs == Sh.head bs + , testProperty "flush" $ \recipe -> let + !(b, toLBS) = recipeComponents recipe + !lbs1 = toLazyByteString b + !lbs2 = L.take (L.length lbs1) (toLBS $ b <> flush <> tooStrictErr) + in lbs1 == lbs2 + ] diff --git a/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/TestUtils.hs b/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/TestUtils.hs deleted file mode 100644 --- a/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/TestUtils.hs +++ /dev/null @@ -1,344 +0,0 @@ --- | --- Copyright : (c) 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : tested on GHC only --- --- Testing utilities for comparing --- for an example on how to use the functions provided here. --- -module Data.ByteString.Lazy.Builder.BasicEncoding.TestUtils ( - - -- * Testing 'FixedEncoding's - testF - , testBoundedF - - , testFixedBoundF - - , compareImpls - - -- * Testing 'BoundedEncoding's - , testBoundedB - - -- * Encoding reference implementations - - , charUtf8_list - , char8_list - - -- ** ASCII-based encodings - , encodeASCII - , encodeForcedASCII - , char7_list - , dec_list - , hex_list - , wordHexFixed_list - , int8HexFixed_list - , int16HexFixed_list - , int32HexFixed_list - , int64HexFixed_list - , floatHexFixed_list - , doubleHexFixed_list - - -- ** Binary - , parseVar - - , bigEndian_list - , littleEndian_list - , hostEndian_list - , float_list - , double_list - , coerceFloatToWord32 - , coerceDoubleToWord64 - - ) where - -import Control.Arrow (first) - -import Data.ByteString.Lazy.Builder.BasicEncoding -import Data.Char (chr, ord) - -import Numeric (showHex) - -#if MIN_VERSION_base(4,4,0) -import Foreign hiding (unsafePerformIO) -import System.IO.Unsafe (unsafePerformIO) -#else -import Foreign -#endif - -import System.ByteOrder -import Unsafe.Coerce (unsafeCoerce) - -import TestFramework -import Test.QuickCheck (Arbitrary(..)) - --- Helper functions -------------------- - --- | Quickcheck test that includes a check that the property holds on the --- bounds of a bounded value. -testBoundedProperty :: forall a. (Arbitrary a, Show a, Bounded a) - => String -> (a -> Bool) -> Test -testBoundedProperty name p = testGroup name - [ testProperty "arbitrary" p - , testCase "bounds" $ p (minBound :: a) - && p (maxBound :: a) - ] - --- | Quote a 'String' nicely. -quote :: String -> String -quote cs = '`' : cs ++ "'" - --- | Quote a @[Word8]@ list as as 'String'. -quoteWord8s :: [Word8] -> String -quoteWord8s = quote . map (chr . fromIntegral) - - --- FixedEncoding ----------------- - --- TODO: Port code that checks for low-level properties of basic encodings (no --- overwrites, all bytes written, etc.) from old 'system-io-write' library - --- | Test a 'FixedEncoding' against a reference implementation. -testF :: (Arbitrary a, Show a) - => String - -> (a -> [Word8]) - -> FixedEncoding a - -> Test -testF name ref fe = - testProperty name prop - where - prop x - | y == y' = True - | otherwise = error $ unlines $ - [ "testF: results disagree for " ++ quote (show x) - , " fixed encoding: " ++ show y ++ " " ++ quoteWord8s y - , " reference: " ++ show y'++ " " ++ quoteWord8s y' - ] - where - y = evalF fe x - y' = ref x - --- | Test a 'FixedEncoding' of a bounded value against a reference implementation --- and ensure that the bounds are always included as testcases. -testBoundedF :: (Arbitrary a, Bounded a, Show a) - => String - -> (a -> [Word8]) - -> FixedEncoding a - -> Test -testBoundedF name ref fe = - testBoundedProperty name $ \x -> evalF fe x == ref x - --- FixedEncoding derived from a bound on a given value. - -testFixedBoundF :: (Arbitrary a, Show a, Integral a) - => String - -> (a -> a -> [Word8]) - -> (a -> FixedEncoding a) - -> Test -testFixedBoundF name ref bfe = - testProperty name prop - where - prop (b, x0) - | y == y' = True - | otherwise = error $ unlines $ - [ "testF: results disagree for " ++ quote (show (b, x)) - , " fixed encoding: " ++ show y ++ " " ++ quoteWord8s y - , " reference: " ++ show y'++ " " ++ quoteWord8s y' - ] - where - x | b == 0 = 0 - | otherwise = x0 `mod` b - y = evalF (bfe b) x - y' = ref b x - - --- BoundedEncoding ------------------- - --- | Test a 'BoundedEncoding' of a bounded value against a reference implementation --- and ensure that the bounds are always included as testcases. -testBoundedB :: (Arbitrary a, Bounded a, Show a) - => String - -> (a -> [Word8]) - -> BoundedEncoding a - -> Test -testBoundedB name ref fe = - testBoundedProperty name check - where - check x - | y == y' = True - | otherwise = error $ unlines $ - [ "testBoundedB: results disagree for " ++ quote (show x) - , " fixed encoding: " ++ show y ++ " " ++ quoteWord8s y - , " reference: " ++ show y'++ " " ++ quoteWord8s y' - ] - where - y = evalB fe x - y' = ref x - --- | Compare two implementations of a function. -compareImpls :: (Arbitrary a, Show a, Show b, Eq b) - => TestName -> (a -> b) -> (a -> b) -> Test -compareImpls name f1 f2 = - testProperty name check - where - check x - | y1 == y2 = True - | otherwise = error $ unlines $ - [ "compareImpls: results disagree for " ++ quote (show x) - , " f1: " ++ show y1 - , " f2: " ++ show y2 - ] - where - y1 = f1 x - y2 = f2 x - - - ------------------------------------------------------------------------------- --- Encoding reference implementations ------------------------------------------------------------------------------- - --- | Char8 encoding: truncate Unicode codepoint to 8-bits. -char8_list :: Char -> [Word8] -char8_list = return . fromIntegral . ord - --- | Encode a Haskell String to a list of Word8 values, in UTF8 format. --- --- Copied from 'utf8-string-0.3.6' to make tests self-contained. --- Copyright (c) 2007, Galois Inc. All rights reserved. --- -charUtf8_list :: Char -> [Word8] -charUtf8_list = - map fromIntegral . encode . ord - where - encode oc - | oc <= 0x7f = [oc] - - | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) - , 0x80 + oc .&. 0x3f - ] - - | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - | otherwise = [ 0xf0 + (oc `shiftR` 18) - , 0x80 + ((oc `shiftR` 12) .&. 0x3f) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - --- ASCII-based encodings ------------------------- - --- | Encode a 'String' of only ASCII characters using the ASCII encoding. -encodeASCII :: String -> [Word8] -encodeASCII = - map encode - where - encode c - | c < '\x7f' = fromIntegral $ ord c - | otherwise = error $ "encodeASCII: non-ASCII character '" ++ [c] ++ "'" - --- | Encode an arbitrary 'String' by truncating its characters to the least --- significant 7-bits. -encodeForcedASCII :: String -> [Word8] -encodeForcedASCII = map ((.&. 0x7f) . fromIntegral . ord) - -char7_list :: Char -> [Word8] -char7_list = encodeForcedASCII . return - -dec_list :: Show a => a -> [Word8] -dec_list = encodeASCII . show - -hex_list :: (Integral a, Show a) => a -> [Word8] -hex_list = encodeASCII . (\x -> showHex x "") - -wordHexFixed_list :: (Storable a, Integral a, Show a) => a -> [Word8] -wordHexFixed_list x = - encodeASCII $ pad (2 * sizeOf x) $ showHex x "" - where - pad n cs = replicate (n - length cs) '0' ++ cs - -int8HexFixed_list :: Int8 -> [Word8] -int8HexFixed_list = wordHexFixed_list . (fromIntegral :: Int8 -> Word8 ) - -int16HexFixed_list :: Int16 -> [Word8] -int16HexFixed_list = wordHexFixed_list . (fromIntegral :: Int16 -> Word16) - -int32HexFixed_list :: Int32 -> [Word8] -int32HexFixed_list = wordHexFixed_list . (fromIntegral :: Int32 -> Word32) - -int64HexFixed_list :: Int64 -> [Word8] -int64HexFixed_list = wordHexFixed_list . (fromIntegral :: Int64 -> Word64) - -floatHexFixed_list :: Float -> [Word8] -floatHexFixed_list = float_list wordHexFixed_list - -doubleHexFixed_list :: Double -> [Word8] -doubleHexFixed_list = double_list wordHexFixed_list - --- Binary ---------- - -bigEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8] -bigEndian_list = reverse . littleEndian_list - -littleEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8] -littleEndian_list x = - map (fromIntegral . (x `shiftR`) . (8*)) $ [0..sizeOf x - 1] - -hostEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8] -hostEndian_list = case byteOrder of - LittleEndian -> littleEndian_list - BigEndian -> bigEndian_list - _ -> error $ - "bounded-encoding: unsupported byteorder '" ++ show byteOrder ++ "'" - - -float_list :: (Word32 -> [Word8]) -> Float -> [Word8] -float_list f = f . coerceFloatToWord32 - -double_list :: (Word64 -> [Word8]) -> Double -> [Word8] -double_list f = f . coerceDoubleToWord64 - --- Note that the following use of unsafeCoerce is not guaranteed to be --- safe on GHC 7.0 and less. The reason is probably the following ticket: --- --- http://hackage.haskell.org/trac/ghc/ticket/4092 --- --- However, that only applies if the value is loaded in a register. We --- avoid this by coercing only boxed values and ensuring that they --- remain boxed using a NOINLINE pragma. --- - --- | Super unsafe coerce a 'Float' to a 'Word32'. We have to explicitly mask --- out the higher bits in case we are working on a 64-bit machine. -{-# NOINLINE coerceFloatToWord32 #-} -coerceFloatToWord32 :: Float -> Word32 -coerceFloatToWord32 = (.&. maxBound) . unsafeCoerce - --- | Super unsafe coerce a 'Double' to a 'Word64'. Currently, there are no --- > 64 bit machines supported by GHC. But we just play it safe. -{-# NOINLINE coerceDoubleToWord64 #-} -coerceDoubleToWord64 :: Double -> Word64 -coerceDoubleToWord64 = (.&. maxBound) . unsafeCoerce - --- | Parse a variable length encoding -parseVar :: (Num a, Bits a) => [Word8] -> (a, [Word8]) -parseVar = - go - where - go [] = error "parseVar: unterminated variable length int" - go (w:ws) - | w .&. 0x80 == 0 = (fromIntegral w, ws) - | otherwise = first add (go ws) - where - add x = (x `shiftL` 7) .|. (fromIntegral w .&. 0x7f) - - diff --git a/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/Tests.hs b/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/Tests.hs deleted file mode 100644 --- a/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/Tests.hs +++ /dev/null @@ -1,337 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Copyright : (c) 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : tested on GHC only --- --- Testing all encodings provided by this library. - -module Data.ByteString.Lazy.Builder.BasicEncoding.Tests (tests) where - -import Control.Arrow (first) - -import Data.Char (ord) -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Lazy.Builder -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as BE -import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Extras as BE -import Data.ByteString.Lazy.Builder.BasicEncoding.TestUtils - -import Numeric (showHex) - -import Foreign - -import TestFramework -import Test.QuickCheck (Arbitrary) - - -tests :: [Test] -tests = concat [ testsBinary, testsASCII, testsChar8, testsUtf8 - , testsCombinatorsB ] - - ------------------------------------------------------------------------------- --- Binary ------------------------------------------------------------------------------- - -testsBinary :: [Test] -testsBinary = - [ testBoundedF "word8" bigEndian_list BE.word8 - , testBoundedF "int8" bigEndian_list BE.int8 - - -- big-endian - , testBoundedF "int16BE" bigEndian_list BE.int16BE - , testBoundedF "int32BE" bigEndian_list BE.int32BE - , testBoundedF "int64BE" bigEndian_list BE.int64BE - - , testBoundedF "word16BE" bigEndian_list BE.word16BE - , testBoundedF "word32BE" bigEndian_list BE.word32BE - , testBoundedF "word64BE" bigEndian_list BE.word64BE - - , testF "floatLE" (float_list littleEndian_list) BE.floatLE - , testF "doubleLE" (double_list littleEndian_list) BE.doubleLE - - -- little-endian - , testBoundedF "int16LE" littleEndian_list BE.int16LE - , testBoundedF "int32LE" littleEndian_list BE.int32LE - , testBoundedF "int64LE" littleEndian_list BE.int64LE - - , testBoundedF "word16LE" littleEndian_list BE.word16LE - , testBoundedF "word32LE" littleEndian_list BE.word32LE - , testBoundedF "word64LE" littleEndian_list BE.word64LE - - , testF "floatBE" (float_list bigEndian_list) BE.floatBE - , testF "doubleBE" (double_list bigEndian_list) BE.doubleBE - - -- host dependent - , testBoundedF "int16Host" hostEndian_list BE.int16Host - , testBoundedF "int32Host" hostEndian_list BE.int32Host - , testBoundedF "int64Host" hostEndian_list BE.int64Host - , testBoundedF "intHost" hostEndian_list BE.intHost - - , testBoundedF "word16Host" hostEndian_list BE.word16Host - , testBoundedF "word32Host" hostEndian_list BE.word32Host - , testBoundedF "word64Host" hostEndian_list BE.word64Host - , testBoundedF "wordHost" hostEndian_list BE.wordHost - - , testF "floatHost" (float_list hostEndian_list) BE.floatHost - , testF "doubleHost" (double_list hostEndian_list) BE.doubleHost - - , testBoundedB "word8Var" genVar_list BE.word8Var - , testBoundedB "word16Var" genVar_list BE.word16Var - , testBoundedB "word32Var" genVar_list BE.word32Var - , testBoundedB "word64Var" genVar_list BE.word64Var - , testBoundedB "wordVar" genVar_list BE.wordVar - - , testBoundedB "int8Var" int8Var_list BE.int8Var - , testBoundedB "int16Var" int16Var_list BE.int16Var - , testBoundedB "int32Var" int32Var_list BE.int32Var - , testBoundedB "int64Var" int64Var_list BE.int64Var - , testBoundedB "intVar" intVar_list BE.intVar - - , testBoundedB "int8VarSigned" (int8Var_list . zigZag) BE.int8VarSigned - , testBoundedB "int16VarSigned" (int16Var_list . zigZag) BE.int16VarSigned - , testBoundedB "int32VarSigned" (int32Var_list . zigZag) BE.int32VarSigned - , testBoundedB "int64VarSigned" (int64Var_list . zigZag) BE.int64VarSigned - , testBoundedB "intVarSigned" (intVar_list . zigZag) BE.intVarSigned - - , testGroup "parseable" - [ prop_zigZag_parseable "int8VarSigned" unZigZagInt8 BE.int8VarSigned - , prop_zigZag_parseable "int16VarSigned" unZigZagInt16 BE.int16VarSigned - , prop_zigZag_parseable "int32VarSigned" unZigZagInt32 BE.int32VarSigned - , prop_zigZag_parseable "int64VarSigned" unZigZagInt64 BE.int64VarSigned - , prop_zigZag_parseable "intVarSigned" unZigZagInt BE.intVarSigned - ] - - , testFixedBoundF "wordVarFixedBound" wordVarFixedBound_list BE.wordVarFixedBound - , testFixedBoundF "word64VarFixedBound" word64VarFixedBound_list BE.word64VarFixedBound - - ] - - --- Variable length encodings ----------------------------- - --- | Variable length encoding. -genVar_list :: (Ord a, Num a, Bits a, Integral a) => a -> [Word8] -genVar_list x - | x <= 0x7f = sevenBits : [] - | otherwise = (sevenBits .|. 0x80) : genVar_list (x `shiftR` 7) - where - sevenBits = fromIntegral x .&. 0x7f - -int8Var_list :: Int8 -> [Word8] -int8Var_list = genVar_list . (fromIntegral :: Int8 -> Word8) - -int16Var_list :: Int16 -> [Word8] -int16Var_list = genVar_list . (fromIntegral :: Int16 -> Word16) - -int32Var_list :: Int32 -> [Word8] -int32Var_list = genVar_list . (fromIntegral :: Int32 -> Word32) - -int64Var_list :: Int64 -> [Word8] -int64Var_list = genVar_list . (fromIntegral :: Int64 -> Word64) - -intVar_list :: Int -> [Word8] -intVar_list = genVar_list . (fromIntegral :: Int -> Word) - - --- | The so-called \"zig-zag\" encoding from Google's protocol buffers. --- It maps integers of small magnitude to naturals of small --- magnitude by encoding negative integers as odd naturals and positive --- integers as even naturals. --- --- For example: @0 -> 0, -1 -> 1, 1 -> 2, -2 -> 3, 2 -> 4, ...@ --- --- PRE: 'a' must be a signed integer type. -zigZag :: (Storable a, Bits a) => a -> a -zigZag x = (x `shiftL` 1) `xor` (x `shiftR` (8 * sizeOf x - 1)) - - --- | Reversing the zigZag encoding. --- --- PRE: 'a' must be an unsigned integer type. --- --- forall x. fromIntegral x == --- unZigZag ((fromIntegral :: IntX -> WordX) (zigZag x)) --- -unZigZag :: (Storable a, Num a, Bits a) => a -> a -unZigZag x = (x `shiftR` 1) `xor` negate (x .&. 1) - -unZigZagInt8 :: Int8 -> Int8 -unZigZagInt8 = (fromIntegral :: Word8 -> Int8) . unZigZag . fromIntegral - -unZigZagInt16 :: Int16 -> Int16 -unZigZagInt16 = (fromIntegral :: Word16 -> Int16) . unZigZag . fromIntegral - -unZigZagInt32 :: Int32 -> Int32 -unZigZagInt32 = (fromIntegral :: Word32 -> Int32) . unZigZag . fromIntegral - -unZigZagInt64 :: Int64 -> Int64 -unZigZagInt64 = (fromIntegral :: Word64 -> Int64) . unZigZag . fromIntegral - -unZigZagInt :: Int -> Int -unZigZagInt = (fromIntegral :: Word -> Int) . unZigZag . fromIntegral - --- | Check that the 'intVarSigned' encodings are parseable. -prop_zigZag_parseable :: (Arbitrary t, Num b, Bits b, Show t, Eq t) - => String -> (b -> t) -> BE.BoundedEncoding t -> Test -prop_zigZag_parseable name unZig be = - compareImpls name (\x -> (x, [])) (first unZig . parseVar . BE.evalB be) - --- | Variable length encoding to a fixed number of bytes (pad / truncate). -genVarFixedBound_list :: (Ord a, Num a, Bits a, Integral a) - => Int - -> a -> [Word8] -genVarFixedBound_list n x - | n <= 1 = sevenBits : [] - | otherwise = (sevenBits .|. 0x80) : genVarFixedBound_list (n - 1) (x `shiftR` 7) - where - sevenBits = fromIntegral x .&. 0x7f - -wordVarFixedBound_list :: Word -> Word -> [Word8] -wordVarFixedBound_list bound = genVarFixedBound_list (length $ genVar_list bound) - -word64VarFixedBound_list :: Word64 -> Word64 -> [Word8] -word64VarFixedBound_list bound = genVarFixedBound_list (length $ genVar_list bound) - --- Somehow this function doesn't really make sense, as the bound must be --- greater when interpreted as an unsigned integer. --- --- intVarFixedBound_list :: Int -> Int -> [Word8] --- intVarFixedBound_list bound = wordVarFixedBound_list (fromIntegral bound) . fromIntegral - - ------------------------------------------------------------------------------- --- Latin-1 aka Char8 ------------------------------------------------------------------------------- - -testsChar8 :: [Test] -testsChar8 = - [ testBoundedF "char8" char8_list BE.char8 ] - - ------------------------------------------------------------------------------- --- ASCII ------------------------------------------------------------------------------- - -testsASCII :: [Test] -testsASCII = - [ testBoundedF "char7" char7_list BE.char7 - - , testBoundedB "int8Dec" dec_list BE.int8Dec - , testBoundedB "int16Dec" dec_list BE.int16Dec - , testBoundedB "int32Dec" dec_list BE.int32Dec - , testBoundedB "int64Dec" dec_list BE.int64Dec - , testBoundedB "intDec" dec_list BE.intDec - - , testBoundedB "word8Dec" dec_list BE.word8Dec - , testBoundedB "word16Dec" dec_list BE.word16Dec - , testBoundedB "word32Dec" dec_list BE.word32Dec - , testBoundedB "word64Dec" dec_list BE.word64Dec - , testBoundedB "wordDec" dec_list BE.wordDec - - , testBoundedB "word8Hex" hex_list BE.word8Hex - , testBoundedB "word16Hex" hex_list BE.word16Hex - , testBoundedB "word32Hex" hex_list BE.word32Hex - , testBoundedB "word64Hex" hex_list BE.word64Hex - , testBoundedB "wordHex" hex_list BE.wordHex - - , testBoundedF "word8HexFixed" wordHexFixed_list BE.word8HexFixed - , testBoundedF "word16HexFixed" wordHexFixed_list BE.word16HexFixed - , testBoundedF "word32HexFixed" wordHexFixed_list BE.word32HexFixed - , testBoundedF "word64HexFixed" wordHexFixed_list BE.word64HexFixed - - , testBoundedF "int8HexFixed" int8HexFixed_list BE.int8HexFixed - , testBoundedF "int16HexFixed" int16HexFixed_list BE.int16HexFixed - , testBoundedF "int32HexFixed" int32HexFixed_list BE.int32HexFixed - , testBoundedF "int64HexFixed" int64HexFixed_list BE.int64HexFixed - - , testF "floatHexFixed" floatHexFixed_list BE.floatHexFixed - , testF "doubleHexFixed" doubleHexFixed_list BE.doubleHexFixed - - , testFixedBoundF "wordDecFixedBound" - (genDecFixedBound_list 'x') (BE.wordDecFixedBound 'x') - - , testFixedBoundF "word64DecFixedBound" - (genDecFixedBound_list 'x') (BE.word64DecFixedBound 'x') - - , testFixedBoundF "wordHexFixedBound" - (genHexFixedBound_list 'x') (BE.wordHexFixedBound 'x') - - , testFixedBoundF "word64HexFixedBound" - (genHexFixedBound_list 'x') (BE.word64HexFixedBound 'x') - ] - --- | PRE: positive bound and value. -genDecFixedBound_list :: (Show a, Integral a) - => Char -- ^ Padding character. - -> a -- ^ Max value to be encoded. - -> a -- ^ Value to encode. - -> [Word8] -genDecFixedBound_list padChar bound = - encodeASCII . pad . show - where - n = length $ show bound - pad cs = replicate (n - length cs) padChar ++ cs - --- | PRE: positive bound and value. -genHexFixedBound_list :: (Show a, Integral a) - => Char -- ^ Padding character. - -> a -- ^ Max value to be encoded. - -> a -- ^ Value to encode. - -> [Word8] -genHexFixedBound_list padChar bound = - encodeASCII . pad . (`showHex` "") - where - n = length $ (`showHex` "") bound - pad cs = replicate (n - length cs) padChar ++ cs - - ------------------------------------------------------------------------------- --- UTF-8 ------------------------------------------------------------------------------- - -testsUtf8 :: [Test] -testsUtf8 = - [ testBoundedB "charUtf8" charUtf8_list BE.charUtf8 ] - - ------------------------------------------------------------------------------- --- BoundedEncoding combinators ------------------------------------------------------------------------------- - -maybeB :: BE.BoundedEncoding () -> BE.BoundedEncoding a -> BE.BoundedEncoding (Maybe a) -maybeB nothing just = maybe (Left ()) Right BE.>$< BE.eitherB nothing just - -testsCombinatorsB :: [Test] -testsCombinatorsB = - [ compareImpls "mapMaybe (via BoundedEncoding)" - (L.pack . concatMap encChar) - (toLazyByteString . encViaBuilder) - - , compareImpls "filter (via BoundedEncoding)" - (L.pack . filter (< 32)) - (toLazyByteString . BE.encodeListWithB (BE.ifB (< 32) (BE.fromF BE.word8) BE.emptyB)) - - , compareImpls "pairB" - (L.pack . concatMap (\(c,w) -> charUtf8_list c ++ [w])) - (toLazyByteString . BE.encodeListWithB - ((\(c,w) -> (c,(w,undefined))) BE.>$< - BE.charUtf8 BE.>*< (BE.fromF BE.word8) BE.>*< (BE.fromF BE.emptyF))) - ] - where - encChar = maybe [112] (hostEndian_list . ord) - - encViaBuilder = BE.encodeListWithB $ maybeB (BE.fromF $ (\_ -> 112) BE.>$< BE.word8) - (ord BE.>$< (BE.fromF $ BE.intHost)) - - - - - - diff --git a/tests/builder/Data/ByteString/Lazy/Builder/Tests.hs b/tests/builder/Data/ByteString/Lazy/Builder/Tests.hs deleted file mode 100644 --- a/tests/builder/Data/ByteString/Lazy/Builder/Tests.hs +++ /dev/null @@ -1,636 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- Copyright : (c) 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : tested on GHC only --- --- Testing composition of 'Builders'. - -module Data.ByteString.Lazy.Builder.Tests (tests) where - - -import Control.Applicative -import Control.Monad.State -import Control.Monad.Writer - -import Foreign (Word, Word8, Word64, minusPtr) -import System.IO.Unsafe (unsafePerformIO) - -import Data.Char (ord, chr) -import qualified Data.DList as D -import Data.Foldable (asum, foldMap) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - -import Data.ByteString.Lazy.Builder -import Data.ByteString.Lazy.Builder.Extras -import Data.ByteString.Lazy.Builder.ASCII -import Data.ByteString.Lazy.Builder.Internal (Put, putBuilder, fromPut) -import qualified Data.ByteString.Lazy.Builder.Internal as BI -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as BE -import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Extras as BE -import Data.ByteString.Lazy.Builder.BasicEncoding.TestUtils - -import Numeric (readHex) - -import Control.Exception (evaluate) -import System.IO (openTempFile, hPutStr, hClose, hSetBinaryMode) -#if MIN_VERSION_base(4,2,0) -import System.IO (hSetEncoding, utf8) -#endif -import System.Directory - -import TestFramework -import Test.QuickCheck - ( Arbitrary(..), oneof, choose, listOf, elements ) -import Test.QuickCheck.Property (printTestCase) - - -tests :: [Test] -tests = - [ testBuilderRecipe -#if MIN_VERSION_base(4,2,0) - , testHandlePutBuilder -#endif - , testHandlePutBuilderChar8 - , testPut - ] ++ - testsEncodingToBuilder ++ - testsBinary ++ - testsASCII ++ - testsChar8 ++ - testsUtf8 - - ------------------------------------------------------------------------------- --- Testing 'Builder' execution ------------------------------------------------------------------------------- - -testBuilderRecipe :: Test -testBuilderRecipe = - testProperty "toLazyByteStringWith" $ testRecipe <$> arbitrary - where - testRecipe r = - printTestCase msg $ x1 == x2 - where - x1 = renderRecipe r - x2 = buildRecipe r - toString = map (chr . fromIntegral) - msg = unlines - [ "recipe: " ++ show r - , "render: " ++ toString x1 - , "build : " ++ toString x2 - , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) - ] - -#if MIN_VERSION_base(4,2,0) -testHandlePutBuilder :: Test -testHandlePutBuilder = - testProperty "hPutBuilder" testRecipe - where - testRecipe :: (String, String, String, Recipe) -> Bool - testRecipe args@(before, between, after, recipe) = unsafePerformIO $ do - tempDir <- getTemporaryDirectory - (tempFile, tempH) <- openTempFile tempDir "TestBuilder" - -- switch to UTF-8 encoding - hSetEncoding tempH utf8 - -- output recipe with intermediate direct writing to handle - let b = fst $ recipeComponents recipe - hPutStr tempH before - hPutBuilder tempH b - hPutStr tempH between - hPutBuilder tempH b - hPutStr tempH after - hClose tempH - -- read file - lbs <- L.readFile tempFile - _ <- evaluate (L.length $ lbs) - removeFile tempFile - -- compare to pure builder implementation - let lbsRef = toLazyByteString $ mconcat - [stringUtf8 before, b, stringUtf8 between, b, stringUtf8 after] - -- report - let msg = unlines - [ "task: " ++ show args - , "via file: " ++ show lbs - , "direct : " ++ show lbsRef - -- , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) - ] - success = lbs == lbsRef - unless success (error msg) - return success -#endif - -testHandlePutBuilderChar8 :: Test -testHandlePutBuilderChar8 = - testProperty "char8 hPutBuilder" testRecipe - where - testRecipe :: (String, String, String, Recipe) -> Bool - testRecipe args@(before, between, after, recipe) = unsafePerformIO $ do - tempDir <- getTemporaryDirectory - (tempFile, tempH) <- openTempFile tempDir "TestBuilder" - -- switch to binary / latin1 encoding - hSetBinaryMode tempH True - -- output recipe with intermediate direct writing to handle - let b = fst $ recipeComponents recipe - hPutStr tempH before - hPutBuilder tempH b - hPutStr tempH between - hPutBuilder tempH b - hPutStr tempH after - hClose tempH - -- read file - lbs <- L.readFile tempFile - _ <- evaluate (L.length $ lbs) - removeFile tempFile - -- compare to pure builder implementation - let lbsRef = toLazyByteString $ mconcat - [string8 before, b, string8 between, b, string8 after] - -- report - let msg = unlines - [ "task: " ++ show args - , "via file: " ++ show lbs - , "direct : " ++ show lbsRef - -- , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) - ] - success = lbs == lbsRef - unless success (error msg) - return success - - --- Recipes with which to test the builder functions ---------------------------------------------------- - -data Mode = - Threshold Int - | Insert - | Copy - | Smart - | Hex - deriving( Eq, Ord, Show ) - -data Action = - SBS Mode S.ByteString - | LBS Mode L.ByteString - | W8 Word8 - | W8S [Word8] - | String String - | FDec Float - | DDec Double - | Flush - | EnsureFree Word - | ModState Int - deriving( Eq, Ord, Show ) - -data Strategy = Safe | Untrimmed - deriving( Eq, Ord, Show ) - -data Recipe = Recipe Strategy Int Int L.ByteString [Action] - deriving( Eq, Ord, Show ) - -renderRecipe :: Recipe -> [Word8] -renderRecipe (Recipe _ firstSize _ cont as) = - D.toList $ execWriter (evalStateT (mapM_ renderAction as) firstSize) - `mappend` renderLBS cont - where - renderAction (SBS Hex bs) = tell $ foldMap hexWord8 $ S.unpack bs - renderAction (SBS _ bs) = tell $ D.fromList $ S.unpack bs - renderAction (LBS Hex lbs) = tell $ foldMap hexWord8 $ L.unpack lbs - renderAction (LBS _ lbs) = tell $ renderLBS lbs - renderAction (W8 w) = tell $ return w - renderAction (W8S ws) = tell $ D.fromList ws - renderAction (String cs) = tell $ foldMap (D.fromList . charUtf8_list) cs - renderAction Flush = tell $ mempty - renderAction (EnsureFree _) = tell $ mempty - renderAction (FDec f) = tell $ D.fromList $ encodeASCII $ show f - renderAction (DDec d) = tell $ D.fromList $ encodeASCII $ show d - renderAction (ModState i) = do - s <- get - tell (D.fromList $ encodeASCII $ show s) - put (s - i) - - - renderLBS = D.fromList . L.unpack - hexWord8 = D.fromList . wordHexFixed_list - -buildAction :: Action -> StateT Int Put () -buildAction (SBS Hex bs) = lift $ putBuilder $ byteStringHexFixed bs -buildAction (SBS Smart bs) = lift $ putBuilder $ byteString bs -buildAction (SBS Copy bs) = lift $ putBuilder $ byteStringCopy bs -buildAction (SBS Insert bs) = lift $ putBuilder $ byteStringInsert bs -buildAction (SBS (Threshold i) bs) = lift $ putBuilder $ byteStringThreshold i bs -buildAction (LBS Hex lbs) = lift $ putBuilder $ lazyByteStringHexFixed lbs -buildAction (LBS Smart lbs) = lift $ putBuilder $ lazyByteString lbs -buildAction (LBS Copy lbs) = lift $ putBuilder $ lazyByteStringCopy lbs -buildAction (LBS Insert lbs) = lift $ putBuilder $ lazyByteStringInsert lbs -buildAction (LBS (Threshold i) lbs) = lift $ putBuilder $ lazyByteStringThreshold i lbs -buildAction (W8 w) = lift $ putBuilder $ word8 w -buildAction (W8S ws) = lift $ putBuilder $ BE.encodeListWithF BE.word8 ws -buildAction (String cs) = lift $ putBuilder $ stringUtf8 cs -buildAction (FDec f) = lift $ putBuilder $ floatDec f -buildAction (DDec d) = lift $ putBuilder $ doubleDec d -buildAction Flush = lift $ putBuilder $ flush -buildAction (EnsureFree minFree) = lift $ putBuilder $ ensureFree $ fromIntegral minFree -buildAction (ModState i) = do - s <- get - lift $ putBuilder $ intDec s - put (s - i) - -buildRecipe :: Recipe -> [Word8] -buildRecipe recipe = - L.unpack $ toLBS b - where - (b, toLBS) = recipeComponents recipe - - -recipeComponents :: Recipe -> (Builder, Builder -> L.ByteString) -recipeComponents (Recipe how firstSize otherSize cont as) = - (b, toLBS) - where - toLBS = toLazyByteStringWith (strategy how firstSize otherSize) cont - where - strategy Safe = safeStrategy - strategy Untrimmed = untrimmedStrategy - - b = fromPut $ evalStateT (mapM_ buildAction as) firstSize - - --- 'Arbitary' instances ------------------------ - -instance Arbitrary L.ByteString where - arbitrary = L.fromChunks <$> listOf arbitrary - shrink lbs - | L.null lbs = [] - | otherwise = pure $ L.take (L.length lbs `div` 2) lbs - -instance Arbitrary S.ByteString where - arbitrary = - trim S.drop =<< trim S.take =<< S.pack <$> listOf arbitrary - where - trim f bs = oneof [pure bs, f <$> choose (0, S.length bs) <*> pure bs] - - shrink bs - | S.null bs = [] - | otherwise = pure $ S.take (S.length bs `div` 2) bs - -instance Arbitrary Mode where - arbitrary = oneof - [Threshold <$> arbitrary, pure Smart, pure Insert, pure Copy, pure Hex] - - shrink (Threshold i) = Threshold <$> shrink i - shrink _ = [] - -instance Arbitrary Action where - arbitrary = oneof - [ SBS <$> arbitrary <*> arbitrary - , LBS <$> arbitrary <*> arbitrary - , W8 <$> arbitrary - , W8S <$> listOf arbitrary - -- ensure that larger character codes are also tested - , String <$> listOf ((\c -> chr (ord c * ord c)) <$> arbitrary) - , pure Flush - -- never request more than 64kb free space - , (EnsureFree . (`mod` 0xffff)) <$> arbitrary - , FDec <$> arbitrary - , DDec <$> arbitrary - , ModState <$> arbitrary - ] - where - - shrink (SBS m bs) = - (SBS <$> shrink m <*> pure bs) <|> - (SBS <$> pure m <*> shrink bs) - shrink (LBS m lbs) = - (LBS <$> shrink m <*> pure lbs) <|> - (LBS <$> pure m <*> shrink lbs) - shrink (W8 w) = W8 <$> shrink w - shrink (W8S ws) = W8S <$> shrink ws - shrink (String cs) = String <$> shrink cs - shrink Flush = [] - shrink (EnsureFree i) = EnsureFree <$> shrink i - shrink (FDec f) = FDec <$> shrink f - shrink (DDec d) = DDec <$> shrink d - shrink (ModState i) = ModState <$> shrink i - -instance Arbitrary Strategy where - arbitrary = elements [Safe, Untrimmed] - shrink _ = [] - -instance Arbitrary Recipe where - arbitrary = - Recipe <$> arbitrary - <*> ((`mod` 33333) <$> arbitrary) -- bound max chunk-sizes - <*> ((`mod` 33337) <$> arbitrary) - <*> arbitrary - <*> listOf arbitrary - - -- shrinking the actions first is desirable - shrink (Recipe a b c d e) = asum - [ (\x -> Recipe a b c d x) <$> shrink e - , (\x -> Recipe a b c x e) <$> shrink d - , (\x -> Recipe a b x d e) <$> shrink c - , (\x -> Recipe a x c d e) <$> shrink b - , (\x -> Recipe x b c d e) <$> shrink a - ] - - ------------------------------------------------------------------------------- --- Creating Builders from basic encodings ------------------------------------------------------------------------------- - -testsEncodingToBuilder :: [Test] -testsEncodingToBuilder = - [ test_encodeUnfoldrF - , test_encodeUnfoldrB - - , compareImpls "encodeSize/Chunked/Size/Chunked (recipe)" - (testBuilder id) - ( - parseChunks parseHexLen . - parseSizePrefix parseHexLen . - parseChunks parseVar . - parseSizePrefix parseHexLen . - testBuilder ( - prefixHexSize . - encodeVar . - prefixHexSize . - encodeHex - ) - ) - - ] - - --- Unfoldr fused with encoding ------------------------------- - -test_encodeUnfoldrF :: Test -test_encodeUnfoldrF = - compareImpls "encodeUnfoldrF word8" id encode - where - toLBS = toLazyByteStringWith (safeStrategy 23 101) L.empty - encode = - L.unpack . toLBS . BE.encodeUnfoldrWithF BE.word8 go - where - go [] = Nothing - go (w:ws) = Just (w, ws) - - -test_encodeUnfoldrB :: Test -test_encodeUnfoldrB = - compareImpls "encodeUnfoldrB charUtf8" (concatMap charUtf8_list) encode - where - toLBS = toLazyByteStringWith (safeStrategy 23 101) L.empty - encode = - L.unpack . toLBS . BE.encodeUnfoldrWithB BE.charUtf8 go - where - go [] = Nothing - go (c:cs) = Just (c, cs) - - --- Chunked encoding and size prefix ------------------------------------ - -testBuilder :: (Builder -> Builder) -> Recipe -> L.ByteString -testBuilder f recipe = - toLBS (f b) - where - (b, toLBS) = recipeComponents $ clearTail recipe - -- need to remove tail of recipe to have a tighter - -- check on encodeWithSize - clearTail (Recipe how firstSize otherSize _ as) = - Recipe how firstSize otherSize L.empty as - --- | Chunked encoding using base-128, variable-length encoding for the --- chunk-size. -encodeVar :: Builder -> Builder -encodeVar = - (`mappend` BE.encodeWithF BE.word8 0) - . (BE.encodeChunked 5 BE.word64VarFixedBound BE.emptyB) - --- | Chunked encoding using 0-padded, space-terminated hexadecimal numbers --- for encoding the chunk-size. -encodeHex :: Builder -> Builder -encodeHex = - (`mappend` BE.encodeWithF (hexLen 0) 0) - . (BE.encodeChunked 7 hexLen BE.emptyB) - -hexLen :: Word64 -> BE.FixedEncoding Word64 -hexLen bound = - (\x -> (x, ' ')) BE.>$< (BE.word64HexFixedBound '0' bound BE.>*< BE.char8) - -parseHexLen :: [Word8] -> (Int, [Word8]) -parseHexLen ws = case span (/= 32) ws of - (lenWS, 32:ws') -> case readHex (map (chr . fromIntegral) lenWS) of - [(len, [])] -> (len, ws') - _ -> error $ "hex parse failed: " ++ show ws - (_, _) -> error $ "unterminated hex-length:" ++ show ws - -parseChunks :: ([Word8] -> (Int, [Word8])) -> L.ByteString -> L.ByteString -parseChunks parseLen = - L.pack . go . L.unpack - where - go ws - | chunkLen == 0 = rest - | chunkLen <= length ws' = chunk ++ go rest - | otherwise = error $ "too few bytes: " ++ show ws - where - (chunkLen, ws') = parseLen ws - (chunk, rest) = splitAt chunkLen ws' - - --- | Prefix with size. We use an inner buffer size of 77 (almost primes are good) to --- get several buffer full signals. -prefixHexSize :: Builder -> Builder -prefixHexSize = BE.encodeWithSize 77 hexLen - -parseSizePrefix :: ([Word8] -> (Int, [Word8])) -> L.ByteString -> L.ByteString -parseSizePrefix parseLen = - L.pack . go . L.unpack - where - go ws - | len <= length ws' = take len ws' - | otherwise = error $ "too few bytes: " ++ show (len, ws, ws') - where - (len, ws') = parseLen ws - - ------------------------------------------------------------------------------- --- Testing the Put monad ------------------------------------------------------------------------------- - -testPut :: Test -testPut = testGroup "Put monad" - [ testLaw "identity" (\v -> (pure id <*> putInt v) `eqPut` (putInt v)) - - , testLaw "composition" $ \(u, v, w) -> - (pure (.) <*> minusInt u <*> minusInt v <*> putInt w) `eqPut` - (minusInt u <*> (minusInt v <*> putInt w)) - - , testLaw "homomorphism" $ \(f, x) -> - (pure (f -) <*> pure x) `eqPut` (pure (f - x)) - - , testLaw "interchange" $ \(u, y) -> - (minusInt u <*> pure y) `eqPut` (pure ($ y) <*> minusInt u) - - , testLaw "ignore left value" $ \(u, v) -> - (putInt u *> putInt v) `eqPut` (pure (const id) <*> putInt u <*> putInt v) - - , testLaw "ignore right value" $ \(u, v) -> - (putInt u <* putInt v) `eqPut` (pure const <*> putInt u <*> putInt v) - - , testLaw "functor" $ \(f, x) -> - (fmap (f -) (putInt x)) `eqPut` (pure (f -) <*> putInt x) - - ] - where - putInt i = putBuilder (integerDec i) >> return i - minusInt i = (-) <$> putInt i - run p = toLazyByteString $ fromPut (do i <- p; _ <- putInt i; return ()) - eqPut p1 p2 = (run p1, run p2) - - testLaw name f = compareImpls name (fst . f) (snd . f) - - ------------------------------------------------------------------------------- --- Testing the Driver <-> Builder protocol ------------------------------------------------------------------------------- - --- | Ensure that there are at least 'n' free bytes for the following 'Builder'. -{-# INLINE ensureFree #-} -ensureFree :: Int -> Builder -ensureFree minFree = - BI.builder step - where - step k br@(BI.BufferRange op ope) - | ope `minusPtr` op < minFree = return $ BI.bufferFull minFree op next - | otherwise = k br - where - next br'@(BI.BufferRange op' ope') - | freeSpace < minFree = - error $ "ensureFree: requested " ++ show minFree ++ " bytes, " ++ - "but got only " ++ show freeSpace ++ " bytes" - | otherwise = k br' - where - freeSpace = ope' `minusPtr` op' - - ------------------------------------------------------------------------------- --- Testing the pre-defined builders ------------------------------------------------------------------------------- - -testBuilderConstr :: (Arbitrary a, Show a) - => TestName -> (a -> [Word8]) -> (a -> Builder) -> Test -testBuilderConstr name ref mkBuilder = - testProperty name check - where - check x = - (ws ++ ws) == - (L.unpack $ toLazyByteString $ mkBuilder x `mappend` mkBuilder x) - where - ws = ref x - - -testsBinary :: [Test] -testsBinary = - [ testBuilderConstr "word8" bigEndian_list word8 - , testBuilderConstr "int8" bigEndian_list int8 - - -- big-endian - , testBuilderConstr "int16BE" bigEndian_list int16BE - , testBuilderConstr "int32BE" bigEndian_list int32BE - , testBuilderConstr "int64BE" bigEndian_list int64BE - - , testBuilderConstr "word16BE" bigEndian_list word16BE - , testBuilderConstr "word32BE" bigEndian_list word32BE - , testBuilderConstr "word64BE" bigEndian_list word64BE - - , testBuilderConstr "floatLE" (float_list littleEndian_list) floatLE - , testBuilderConstr "doubleLE" (double_list littleEndian_list) doubleLE - - -- little-endian - , testBuilderConstr "int16LE" littleEndian_list int16LE - , testBuilderConstr "int32LE" littleEndian_list int32LE - , testBuilderConstr "int64LE" littleEndian_list int64LE - - , testBuilderConstr "word16LE" littleEndian_list word16LE - , testBuilderConstr "word32LE" littleEndian_list word32LE - , testBuilderConstr "word64LE" littleEndian_list word64LE - - , testBuilderConstr "floatBE" (float_list bigEndian_list) floatBE - , testBuilderConstr "doubleBE" (double_list bigEndian_list) doubleBE - - -- host dependent - , testBuilderConstr "int16Host" hostEndian_list int16Host - , testBuilderConstr "int32Host" hostEndian_list int32Host - , testBuilderConstr "int64Host" hostEndian_list int64Host - , testBuilderConstr "intHost" hostEndian_list intHost - - , testBuilderConstr "word16Host" hostEndian_list word16Host - , testBuilderConstr "word32Host" hostEndian_list word32Host - , testBuilderConstr "word64Host" hostEndian_list word64Host - , testBuilderConstr "wordHost" hostEndian_list wordHost - - , testBuilderConstr "floatHost" (float_list hostEndian_list) floatHost - , testBuilderConstr "doubleHost" (double_list hostEndian_list) doubleHost - ] - -testsASCII :: [Test] -testsASCII = - [ testBuilderConstr "char7" char7_list char7 - , testBuilderConstr "string7" (concatMap char7_list) string7 - - , testBuilderConstr "int8Dec" dec_list int8Dec - , testBuilderConstr "int16Dec" dec_list int16Dec - , testBuilderConstr "int32Dec" dec_list int32Dec - , testBuilderConstr "int64Dec" dec_list int64Dec - , testBuilderConstr "intDec" dec_list intDec - - , testBuilderConstr "word8Dec" dec_list word8Dec - , testBuilderConstr "word16Dec" dec_list word16Dec - , testBuilderConstr "word32Dec" dec_list word32Dec - , testBuilderConstr "word64Dec" dec_list word64Dec - , testBuilderConstr "wordDec" dec_list wordDec - - , testBuilderConstr "integerDec" dec_list integerDec - , testBuilderConstr "floatDec" dec_list floatDec - , testBuilderConstr "doubleDec" dec_list doubleDec - - , testBuilderConstr "word8Hex" hex_list word8Hex - , testBuilderConstr "word16Hex" hex_list word16Hex - , testBuilderConstr "word32Hex" hex_list word32Hex - , testBuilderConstr "word64Hex" hex_list word64Hex - , testBuilderConstr "wordHex" hex_list wordHex - - , testBuilderConstr "word8HexFixed" wordHexFixed_list word8HexFixed - , testBuilderConstr "word16HexFixed" wordHexFixed_list word16HexFixed - , testBuilderConstr "word32HexFixed" wordHexFixed_list word32HexFixed - , testBuilderConstr "word64HexFixed" wordHexFixed_list word64HexFixed - - , testBuilderConstr "int8HexFixed" int8HexFixed_list int8HexFixed - , testBuilderConstr "int16HexFixed" int16HexFixed_list int16HexFixed - , testBuilderConstr "int32HexFixed" int32HexFixed_list int32HexFixed - , testBuilderConstr "int64HexFixed" int64HexFixed_list int64HexFixed - - , testBuilderConstr "floatHexFixed" floatHexFixed_list floatHexFixed - , testBuilderConstr "doubleHexFixed" doubleHexFixed_list doubleHexFixed - ] - -testsChar8 :: [Test] -testsChar8 = - [ testBuilderConstr "charChar8" char8_list char8 - , testBuilderConstr "stringChar8" (concatMap char8_list) string8 - ] - -testsUtf8 :: [Test] -testsUtf8 = - [ testBuilderConstr "charUtf8" charUtf8_list charUtf8 - , testBuilderConstr "stringUtf8" (concatMap charUtf8_list) stringUtf8 - ] diff --git a/tests/builder/TestSuite.hs b/tests/builder/TestSuite.hs deleted file mode 100644 --- a/tests/builder/TestSuite.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Main where - ---import Test.Framework (defaultMain, Test, testGroup) - -import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Tests -import qualified Data.ByteString.Lazy.Builder.Tests -import TestFramework - - -main :: IO () -main = defaultMain tests - -tests :: [Test] -tests = - [ testGroup "Data.ByteString.Lazy.Builder" - Data.ByteString.Lazy.Builder.Tests.tests - - , testGroup "Data.ByteString.Lazy.Builder.BasicEncoding" - Data.ByteString.Lazy.Builder.BasicEncoding.Tests.tests - ] -