packages feed

bytestring 0.10.0.2 → 0.12.2.0

raw patch · 87 files changed

Files

+ Changelog.md view
@@ -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))+<!--+* Internal stuff:+  * Various CI tweaks ([1](https://github.com/haskell/bytestring/pull/670), [2](https://github.com/haskell/bytestring/pull/681), [3](https://github.com/haskell/bytestring/pull/686), [4](https://github.com/haskell/bytestring/pull/656), [5](https://github.com/haskell/bytestring/pull/693), [6](https://github.com/haskell/bytestring/pull/699), [7](https://github.com/haskell/bytestring/pull/700))+  * [Use `default-extensions` to tidy up a bit](https://github.com/haskell/bytestring/pull/669)+  * [Remove `includes` from Cabal file](https://github.com/haskell/bytestring/pull/685)+  * [Improve benchmarks for small `Builders`](https://github.com/haskell/bytestring/pull/680)+  * [Add a constraint reflecting](https://github.com/haskell/bytestring/pull/698) [#665](https://github.com/haskell/bytestring/issues/665) [to the package description](https://github.com/haskell/bytestring/pull/698)+-->++[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.+<!--+* Internal stuff:+  * [Delete cabal.project](https://github.com/haskell/bytestring/pull/613)+  * Remove some non-exposed data declarations from internal modules:+    * [`Data.ByteString.Short.Internal.BA`](https://github.com/haskell/bytestring/pull/615)+    * [`Data.ByteString.Short.Internal.MBA`](https://github.com/haskell/bytestring/pull/617)+  * Various CI tweaks ([1](https://github.com/haskell/bytestring/pull/626), [2](https://github.com/haskell/bytestring/pull/651))+  * [Use `NonEmpty` to prune dead code in `integerDec`](https://github.com/haskell/bytestring/pull/655)+    * This might have a performance impact due to result unboxing (CPR).+  * [Consolidate internal CPP for byte-order/endianness](https://github.com/haskell/bytestring/pull/659)+  * [Remove remaining uses of FFI under -fpure-haskell](https://github.com/haskell/bytestring/pull/660)+    * Doesn't warrant a separate visible changelog entry from #631.+-->++[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)+<!--+* Internal stuff:+  * Various CI tweaks ([1](https://github.com/haskell/bytestring/pull/571), [2](https://github.com/haskell/bytestring/pull/565), [3](https://github.com/haskell/bytestring/pull/583), [4](https://github.com/haskell/bytestring/pull/584))+  * [`accursedUnutterablePerformIO`'s trail of destruction extended](https://github.com/haskell/bytestring/pull/579)+  * [Add type signatures for subfunction of `buildStepToCIOS`](https://github.com/haskell/bytestring/pull/586)+  * [`foldl'`-related import list tweaks](https://github.com/haskell/bytestring/pull/585)+-->++[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)+<!--+* Internal stuff:+  * Various CI tweaks ([1](https://github.com/haskell/bytestring/pull/539), [2](https://github.com/haskell/bytestring/pull/550), [3](https://github.com/haskell/bytestring/pull/551), [4](https://github.com/haskell/bytestring/pull/563), [5](https://github.com/haskell/bytestring/pull/566), [6](https://github.com/haskell/bytestring/pull/568))+  * [Avoid pattern-matching with `SBS`, for consistency with master](https://github.com/haskell/bytestring/pull/556)+  * [Avoid `Prelude.head` and `Prelude.tail`](https://github.com/haskell/bytestring/pull/553)+-->++[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 <duncan+haskell@dcoutts.me.uk> 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 <duncan@community.haskell.org> 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 <duncan@community.haskell.org> May 2016++ * Fix Builder output on big-endian architectures+ * Fix building with ghc-7.6 and older++0.10.8.0 Duncan Coutts <duncan@community.haskell.org> 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 <duncan@community.haskell.org> 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 <duncan@community.haskell.org> Nov 2014++ * Fix integer overflow in concatenation functions+ * Fix strictness of lazy bytestring foldl'+ * Numerous minor documentation fixes+ * Various testsuite improvements
Data/ByteString.hs view
@@ -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
+ Data/ByteString/Builder.hs view
@@ -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 <iridcode@gmail.com>+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\\\"\", \"&#955;-w&#246;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 \'&#955;\'+and \'&#246;\' characters, which have a Unicode codepoint above 127, are+expanded to their corresponding UTF-8 multi-byte representation.++We use the @criterion@ library (<http://hackage.haskell.org/package/criterion>)+  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
+ Data/ByteString/Builder/ASCII.hs view
@@ -0,0 +1,315 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Copyright : (c) 2010 - 2011 Simon Meier+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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+-- <bos@mailrank.com>. 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)
+ Data/ByteString/Builder/Extra.hs view
@@ -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 <iridcode@gmail.com>+-- 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+
+ Data/ByteString/Builder/Internal.hs view
@@ -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 <iridcode@gmail.com>+-- 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+-- <https://hackage.haskell.org/package/zlib zlib>+-- 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 (<http://en.wikipedia.org/wiki/Base64>).+--+-- @+--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
+ Data/ByteString/Builder/Prim.hs view
@@ -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 <iridcode@gmail.com>+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.+<http://hackage.haskell.org/cgi-bin/hackage-scripts/package/dlist>. )+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'+    &#160;+    {&#45;\# INLINE fixed2 \#&#45;}+    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\\\"\", \"&#955;-w&#246;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 \'>\'.++@+{&#45;\# INLINE charUtf8HtmlEscaped \#&#45;}+charUtf8HtmlEscaped :: 'BoundedPrim' Char+charUtf8HtmlEscaped =+    'condB' (>  \'\>\' ) 'charUtf8' $+    'condB' (== \'\<\' ) (fixed4 (\'&\',(\'l\',(\'t\',\';\')))) $        -- &lt;+    'condB' (== \'\>\' ) (fixed4 (\'&\',(\'g\',(\'t\',\';\')))) $        -- &gt;+    'condB' (== \'&\' ) (fixed5 (\'&\',(\'a\',(\'m\',(\'p\',\';\'))))) $  -- &amp;+    'condB' (== \'\"\' ) (fixed5 (\'&\',(\'\#\',(\'3\',(\'4\',\';\'))))) $  -- &\#34;+    'condB' (== \'\\\'\') (fixed5 (\'&\',(\'\#\',(\'3\',(\'9\',\';\'))))) $  -- &\#39;+    ('liftFixedToBounded' 'char7')         -- fallback for 'Char's smaller than \'\>\'+  where+    {&#45;\# INLINE fixed4 \#&#45;}+    fixed4 x = 'liftFixedToBounded' $ const x '>$<'+      char7 '>*<' char7 '>*<' char7 '>*<' char7+    &#160;+    {&#45;\# INLINE fixed5 \#&#45;}+    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 (<http://hackage.haskell.org/package/bytestring>). 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
+ Data/ByteString/Builder/Prim/ASCII.hs view
@@ -0,0 +1,268 @@+-- | Copyright   : (c) 2010 Jasper Van der Jeugt+--                 (c) 2010 - 2011 Simon Meier+-- License       : BSD3-style (see LICENSE)+--+-- Maintainer    : Simon Meier <iridcode@gmail.com>+-- 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
+ Data/ByteString/Builder/Prim/Binary.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE Trustworthy #-}++-- | Copyright   : (c) 2010-2011 Simon Meier+-- License       : BSD3-style (see LICENSE)+--+-- Maintainer    : Simon Meier <iridcode@gmail.com>+-- 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
+ Data/ByteString/Builder/Prim/Internal.hs view
@@ -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 <iridcode@gmail.com>+-- 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'+-- <http://hackage.haskell.org/package/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'+-- <http://hackage.haskell.org/package/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
+ Data/ByteString/Builder/Prim/Internal/Base16.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE CPP #-}++-- |+-- Copyright   : (c) 2011 Simon Meier+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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
+ Data/ByteString/Builder/Prim/Internal/Floating.hs view
@@ -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 <iridcode@gmail.com>+-- 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
+ Data/ByteString/Builder/RealFloat.hs view
@@ -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+-- <https://dl.acm.org/doi/10.1145/3192366.3192369 Ryu paper>.+--+-- @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)+
+ Data/ByteString/Builder/RealFloat/D2S.hs view
@@ -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)
+ Data/ByteString/Builder/RealFloat/F2S.hs view
@@ -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)
+ Data/ByteString/Builder/RealFloat/Internal.hs view
@@ -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 <ghcautoconf.h>+#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) #)
+ Data/ByteString/Builder/RealFloat/TableGenerator.hs view
@@ -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)+
Data/ByteString/Char8.hs view
@@ -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:+-- --  * <http://www.unicode.org/charts/> -- --  * <http://www.unicode.org/charts/PDF/U0000.pdf>@@ -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
Data/ByteString/Internal.hs view
@@ -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
+ Data/ByteString/Internal/Pure.hs view
@@ -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"#
+ Data/ByteString/Internal/Type.hs view
@@ -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:+--+-- * <https://github.com/haskell/bytestring/commit/71c4b438c675aa360c79d79acc9a491e7bbc26e7>+--+-- * <https://github.com/haskell/bytestring/commit/210c656390ae617d9ee3b8bcff5c88dd17cef8da>+--+-- * <https://github.com/haskell/aeson/commit/720b857e2e0acf2edc4f5512f2b217a89449a89d>+--+-- * <https://ghc.haskell.org/trac/ghc/ticket/3486>+--+-- * <https://ghc.haskell.org/trac/ghc/ticket/3487>+--+-- * <https://ghc.haskell.org/trac/ghc/ticket/7270>+--+-- * <https://gitlab.haskell.org/ghc/ghc/-/issues/22204>+--+-- 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
Data/ByteString/Lazy.hs view
@@ -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/<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+"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 <N/length -> 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+-- <http://hackage.haskell.org/package/conduit conduit>,+-- <http://hackage.haskell.org/package/machines-bytestring machines-bytestring>,+-- <http://hackage.haskell.org/package/pipes-bytestring pipes-bytestring>,+-- <http://hackage.haskell.org/package/streaming-bytestring streaming-bytestring>,+-- <http://hackage.haskell.org/package/streamly-bytestring streamly-bytestring>,+-- etc.
− Data/ByteString/Lazy/Builder.hs 
@@ -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 <iridcode@gmail.com>-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\\\"\", \"&#955;-w&#246;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 \'&#955;\'-and \'&#246;\' characters, which have a Unicode codepoint above 127, are-expanded to their corresponding UTF-8 multi-byte representation.--We use the @criterion@ library (<http://hackage.haskell.org/package/criterion>)-  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-
− Data/ByteString/Lazy/Builder/ASCII.hs 
@@ -1,268 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface #-}--- | Copyright : (c) 2010 - 2011 Simon Meier--- License     : BSD3-style (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- 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
− Data/ByteString/Lazy/Builder/BasicEncoding.hs 
@@ -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 <iridcode@gmail.com>-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.  <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/dlist>.-)-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'-    &#160;-    {&#45;\# INLINE fixed2 \#&#45;}-    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\\\"\", \"&#955;-w&#246;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 \'>\'.--@-{&#45;\# INLINE charUtf8HtmlEscaped \#&#45;}-charUtf8HtmlEscaped :: E.BoundedEncoding Char-charUtf8HtmlEscaped =-    'ifB' (>  \'\>\' ) E.'charUtf8' $-    'ifB' (== \'\<\' ) (fixed4 (\'&\',(\'l\',(\'t\',\';\')))) $        -- &lt;-    'ifB' (== \'\>\' ) (fixed4 (\'&\',(\'g\',(\'t\',\';\')))) $        -- &gt;-    'ifB' (== \'&\' ) (fixed5 (\'&\',(\'a\',(\'m\',(\'p\',\';\'))))) $  -- &amp;-    'ifB' (== \'\"\' ) (fixed5 (\'&\',(\'\#\',(\'3\',(\'4\',\';\'))))) $  -- &\#34;-    'ifB' (== \'\\\'\') (fixed5 (\'&\',(\'\#\',(\'3\',(\'9\',\';\'))))) $  -- &\#39;-    ('fromF' E.'char7')         -- fallback for 'Char's smaller than \'\>\'-  where-    {&#45;\# INLINE fixed4 \#&#45;}-    fixed4 x = 'fromF' $ const x '>$<'-      E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7-    &#160;-    {&#45;\# INLINE fixed5 \#&#45;}-    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 (<http://hackage.haskell.org/package/bytestring>). 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-  -- <http://hackage.haskell.org/package/contravariant> 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--
− Data/ByteString/Lazy/Builder/BasicEncoding/ASCII.hs 
@@ -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 <iridcode@gmail.com>--- 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--
− Data/ByteString/Lazy/Builder/BasicEncoding/Binary.hs 
@@ -1,336 +0,0 @@-{-# LANGUAGE CPP, BangPatterns #-}--- | Copyright   : (c) 2010-2011 Simon Meier--- License       : BSD3-style (see LICENSE)------ Maintainer    : Simon Meier <iridcode@gmail.com>--- 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--
− Data/ByteString/Lazy/Builder/BasicEncoding/Extras.hs 
@@ -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 <iridcode@gmail.com>-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 (<http://hackage.haskell.org/package/bytestring>). 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-<http://code.google.com/apis/protocolbuffers/docs/encoding.html#varints>.  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-  (<http://code.google.com/apis/protocolbuffers/docs/encoding.html#types>).-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 <http://en.wikipedia.org/wiki/Basic_Encoding_Rules>-or Google's protocol buffers <http://code.google.com/p/protobuf/> 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-
− Data/ByteString/Lazy/Builder/BasicEncoding/Internal.hs 
@@ -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 <iridcode@gmail.com>--- 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'--- <http://hackage.haskell.org/package/contravariant>. 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'--- <http://hackage.haskell.org/package/contravariant>. 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---}---
− Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Base16.hs 
@@ -1,116 +0,0 @@-{-# LANGUAGE CPP #-}--- |--- Copyright   : (c) 2011 Simon Meier--- License     : BSD3-style (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- 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--}
− Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Floating.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- |--- Copyright   : (c) 2010 Simon Meier------ License     : BSD3-style (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- 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-
− Data/ByteString/Lazy/Builder/BasicEncoding/Internal/UncheckedShifts.hs 
@@ -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 <iridcode@gmail.com>--- 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--
− Data/ByteString/Lazy/Builder/Extras.hs 
@@ -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 <iridcode@gmail.com>--- 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-
− Data/ByteString/Lazy/Builder/Internal.hs 
@@ -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 <iridcode@gmail.com>--- 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
Data/ByteString/Lazy/Char8.hs view
@@ -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
Data/ByteString/Lazy/Internal.hs view
@@ -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.
+ Data/ByteString/Lazy/ReadInt.hs view
@@ -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+            -- <https://gitlab.haskell.org/ghc/ghc/-/issues/20739>.+            --+            -- 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'
+ Data/ByteString/Lazy/ReadNat.hs view
@@ -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:+    -- <https://gmplib.org/manual/Multiplication-Algorithms>+    --+    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+            -- <https://gitlab.haskell.org/ghc/ghc/-/issues/20739>.+            --+            -- 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
+ Data/ByteString/ReadInt.hs view
@@ -0,0 +1,3 @@+{-# LANGUAGE CPP #-}+#define BYTESTRING_STRICT+#include "Lazy/ReadInt.hs"
+ Data/ByteString/ReadNat.hs view
@@ -0,0 +1,3 @@+{-# LANGUAGE CPP #-}+#define BYTESTRING_STRICT+#include "Lazy/ReadNat.hs"
+ Data/ByteString/Short.hs view
@@ -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 ()+
+ Data/ByteString/Short/Internal.hs view
@@ -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 #-}+
Data/ByteString/Unsafe.hs view
@@ -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
+ Data/ByteString/Utils/ByteOrder.hs view
@@ -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
+ Data/ByteString/Utils/UnalignedAccess.hs view
@@ -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+
LICENSE view
@@ -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.
− README 
@@ -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  --
+ README.md view
@@ -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.
− TODO 
@@ -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"]]
bench/BenchAll.hs view
@@ -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     ]
+ bench/BenchBoundsCheckFusion.hs view
@@ -0,0 +1,103 @@+-- |+-- Copyright   : (c) 2011 Simon Meier+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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))+  #-}+
+ bench/BenchCSV.hs view
@@ -0,0 +1,555 @@+{-# LANGUAGE CPP #-}++-- |+-- Copyright   : (c) 2010-2011 Simon Meier+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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 }+++-}
+ bench/BenchCount.hs view
@@ -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..])
+ bench/BenchIndices.hs view
@@ -0,0 +1,81 @@+-- |+-- Copyright   : (c) 2020 Peter Duchovni+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Peter Duchovni <caufeminecraft+github@gmail.com>+--+-- 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 #-}
+ bench/BenchReadInt.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE CPP #-}++-- |+-- Copyright   : (c) 2021 Viktor Dukhovni+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Viktor Dukhovni <ietf-dane@dukhovni.org>+--+-- 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
+ bench/BenchShort.hs view
@@ -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+        ]+    ]
− bench/BoundsCheckFusion.hs 
@@ -1,127 +0,0 @@-{-# LANGUAGE PackageImports, ScopedTypeVariables, BangPatterns #-}--- |--- Copyright   : (c) 2011 Simon Meier--- License     : BSD3-style (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- 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))-  #-}-
bytestring.cabal view
@@ -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 <dons00@gmail.com>,-                     Duncan Coutts <duncan@community.haskell.org>-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 <andrew.lelechenko@gmail.com>, 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
+ cbits/aarch64/is-valid-utf8.c view
@@ -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 <arm_neon.h>+#include <stdbool.h>+#include <stddef.h>+#include <stdint.h>++// 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
+ cbits/aligned-static-hs-data.c view
@@ -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 <stdint.h>++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+};
cbits/fpstring.c view
@@ -29,10 +29,25 @@  * SUCH DAMAGE.  */ +#include "HsFFI.h"+#include "MachDeps.h"+ #include "fpstring.h"+#if defined(__x86_64__)+#include <x86intrin.h>+#include <cpuid.h>+#endif +#include <stdint.h>+#include <stdbool.h>++#if defined(__x86_64__) && (__GNUC__ >= 7 || __GNUC__ == 6 && __GNUC_MINOR__ >= 3 || defined(__clang_major__)) && !defined(__STDC_NO_ATOMICS__)+#include <stdatomic.h>+#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 }
+ cbits/is-valid-utf8.c view
@@ -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 <stdbool.h>+#include <stddef.h>+#include <stdint.h>+#include <string.h>++#ifdef __x86_64__+#include <cpuid.h>+#include <emmintrin.h>+#include <immintrin.h>+#if (__GNUC__ >= 7 || __GNUC__ == 6 && __GNUC_MINOR__ >= 3 ||                  \+     defined(__clang_major__)) &&                                              \+    !defined(__STDC_NO_ATOMICS__)+#include <stdatomic.h>+#include <tmmintrin.h>+#else+// This is needed to support CentOS 7, which has a very old GCC.+#define CRUFTY_GCC+#endif+#endif++#include <MachDeps.h>+#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
cbits/itoa.c view
@@ -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'; } }
+ cbits/shortbytestring.c view
@@ -0,0 +1,21 @@+#include <assert.h>+#include <stddef.h>+#include <stdint.h>+#include <string.h>+++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;+    }+}
+ include/bytestring-cpp-macros.h view
@@ -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)
include/fpstring.h view
@@ -1,9 +1,9 @@- #include <string.h>--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 <stdlib.h> +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);
+ tests/Builder.hs view
@@ -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+  ]
+ tests/IsValidUtf8.hs view
@@ -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
+ tests/LazyHClose.hs view
@@ -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
+ tests/Lift.hs view
@@ -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
+ tests/Main.hs view
@@ -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+  ]
tests/Properties.hs view
@@ -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
+ tests/Properties/ByteString.hs view
@@ -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
+ tests/Properties/ByteStringChar8.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE CPP #-}++#define BYTESTRING_CHAR8++#include "ByteString.hs"
+ tests/Properties/ByteStringLazy.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE CPP #-}++#define BYTESTRING_LAZY++#include "ByteString.hs"
+ tests/Properties/ByteStringLazyChar8.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE CPP #-}++#define BYTESTRING_LAZY+#define BYTESTRING_CHAR8++#include "ByteString.hs"
+ tests/Properties/ShortByteString.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE CPP #-}++#define BYTESTRING_SHORT++#include "ByteString.hs"
tests/QuickCheckUtils.hs view
@@ -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"
− tests/Rules.hs 
@@ -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-    ]
− tests/TestFramework.hs 
@@ -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!"
+ tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs view
@@ -0,0 +1,381 @@+{-# LANGUAGE CPP #-}++-- |+-- Copyright   : (c) 2011 Simon Meier+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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 <ghcautoconf.h>++-- 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)
+ tests/builder/Data/ByteString/Builder/Prim/Tests.hs view
@@ -0,0 +1,172 @@+-- |+-- Copyright   : (c) 2011 Simon Meier+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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))
+ tests/builder/Data/ByteString/Builder/Tests.hs view
@@ -0,0 +1,1025 @@+-- |+-- Copyright   : (c) 2011 Simon Meier+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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+  ]
− tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/TestUtils.hs 
@@ -1,344 +0,0 @@--- |--- Copyright   : (c) 2011 Simon Meier--- License     : BSD3-style (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- 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)--
− tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/Tests.hs 
@@ -1,337 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}---- |--- Copyright   : (c) 2011 Simon Meier--- License     : BSD3-style (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- 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))------
− tests/builder/Data/ByteString/Lazy/Builder/Tests.hs 
@@ -1,636 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- |--- Copyright   : (c) 2011 Simon Meier--- License     : BSD3-style (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- 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-  ]
− tests/builder/TestSuite.hs 
@@ -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-  ]-