bytestring 0.9.2.1 → 0.12.2.0
raw patch · 69 files changed
Files
- Changelog.md +361/−0
- Data/ByteString.hs +2090/−2124
- Data/ByteString/Builder.hs +476/−0
- Data/ByteString/Builder/ASCII.hs +315/−0
- Data/ByteString/Builder/Extra.hs +209/−0
- Data/ByteString/Builder/Internal.hs +1219/−0
- Data/ByteString/Builder/Prim.hs +778/−0
- Data/ByteString/Builder/Prim/ASCII.hs +268/−0
- Data/ByteString/Builder/Prim/Binary.hs +247/−0
- Data/ByteString/Builder/Prim/Internal.hs +312/−0
- Data/ByteString/Builder/Prim/Internal/Base16.hs +60/−0
- Data/ByteString/Builder/Prim/Internal/Floating.hs +88/−0
- Data/ByteString/Builder/RealFloat.hs +287/−0
- Data/ByteString/Builder/RealFloat/D2S.hs +863/−0
- Data/ByteString/Builder/RealFloat/F2S.hs +304/−0
- Data/ByteString/Builder/RealFloat/Internal.hs +864/−0
- Data/ByteString/Builder/RealFloat/TableGenerator.hs +203/−0
- Data/ByteString/Char8.hs +375/−401
- Data/ByteString/Fusion.hs +0/−24
- Data/ByteString/Internal.hs +65/−375
- Data/ByteString/Internal/Pure.hs +418/−0
- Data/ByteString/Internal/Type.hs +1298/−0
- Data/ByteString/Lazy.hs +1790/−1371
- Data/ByteString/Lazy/Char8.hs +413/−348
- Data/ByteString/Lazy/Internal.hs +264/−43
- Data/ByteString/Lazy/ReadInt.hs +259/−0
- Data/ByteString/Lazy/ReadNat.hs +252/−0
- Data/ByteString/ReadInt.hs +3/−0
- Data/ByteString/ReadNat.hs +3/−0
- Data/ByteString/Short.hs +181/−0
- Data/ByteString/Short/Internal.hs +1777/−0
- Data/ByteString/Unsafe.hs +122/−144
- Data/ByteString/Utils/ByteOrder.hs +40/−0
- Data/ByteString/Utils/UnalignedAccess.hs +93/−0
- LICENSE +4/−2
- README +0/−205
- README.md +28/−0
- TODO +0/−71
- bench/BenchAll.hs +583/−0
- bench/BenchBoundsCheckFusion.hs +103/−0
- bench/BenchCSV.hs +555/−0
- bench/BenchCount.hs +29/−0
- bench/BenchIndices.hs +81/−0
- bench/BenchReadInt.hs +138/−0
- bench/BenchShort.hs +246/−0
- bytestring.cabal +233/−71
- cbits/aarch64/is-valid-utf8.c +284/−0
- cbits/aligned-static-hs-data.c +756/−0
- cbits/fpstring.c +246/−10
- cbits/is-valid-utf8.c +782/−0
- cbits/itoa.c +215/−0
- cbits/shortbytestring.c +21/−0
- include/bytestring-cpp-macros.h +50/−0
- include/fpstring.h +8/−5
- tests/Builder.hs +14/−0
- tests/IsValidUtf8.hs +364/−0
- tests/LazyHClose.hs +64/−0
- tests/Lift.hs +68/−0
- tests/Main.hs +18/−0
- tests/Properties.hs +750/−2348
- tests/Properties/ByteString.hs +830/−0
- tests/Properties/ByteStringChar8.hs +5/−0
- tests/Properties/ByteStringLazy.hs +5/−0
- tests/Properties/ByteStringLazyChar8.hs +6/−0
- tests/Properties/ShortByteString.hs +5/−0
- tests/QuickCheckUtils.hs +142/−0
- tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs +381/−0
- tests/builder/Data/ByteString/Builder/Prim/Tests.hs +172/−0
- tests/builder/Data/ByteString/Builder/Tests.hs +1025/−0
+ 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,2124 +1,2090 @@-{-# LANGUAGE CPP #-}--- We cannot actually specify all the language pragmas, see ghc ticket #--- If we could, these are what they would be:-{- LANGUAGE MagicHash, UnboxedTuples,- NamedFieldPuns, BangPatterns, RecordWildCards -}-{-# 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------ Array fusion code:--- (c) 2001,2002 Manuel M T Chakravarty & Gabriele Keller--- (c) 2006 Manuel M T Chakravarty & Roman Leshchinskiy------ License : BSD-style------ Maintainer : dons@cse.unsw.edu.au--- Stability : experimental--- 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.--- Polished and extended by Don Stewart.-----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)-#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, mempty, mappend, mconcat)--#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 (stToIO, unsafePerformIO)-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#, (+#), writeWord8OffAddr#)-import GHC.Base (build)-import GHC.Word hiding (Word8)-import GHC.Ptr (Ptr(..))-import GHC.ST (ST(..))--#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---- ----------------------------------------------------------------------------------- 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---- -------------------------------------------------------------------------------instance Eq ByteString where- (==) = eq--instance Ord ByteString where- compare = compareBytes--instance Monoid ByteString where- mempty = empty- mappend = append- mconcat = concat---- | /O(n)/ Equality on the 'ByteString' type.-eq :: ByteString -> ByteString -> Bool-eq a@(PS p s l) b@(PS p' s' l')- | l /= l' = False -- short cut on length- | p == p' && s == s' = True -- short cut for the same string- | otherwise = compareBytes a b == EQ-{-# INLINE eq #-}--- ^ still needed---- | /O(n)/ 'compareBytes' provides an 'Ordering' for 'ByteStrings' supporting slices. -compareBytes :: ByteString -> ByteString -> Ordering-compareBytes (PS x1 s1 l1) (PS x2 s2 l2)- | l1 == 0 && l2 == 0 = EQ -- short cut for empty strings- | otherwise = inlinePerformIO $- withForeignPtr x1 $ \p1 ->- withForeignPtr x2 $ \p2 -> do- i <- memcmp (p1 `plusPtr` s1) (p2 `plusPtr` s2) (fromIntegral $ min l1 l2)- return $! case i `compare` 0 of- EQ -> l1 `compare` l2- x -> x--{----- Pure Haskell version--compareBytes (PS fp1 off1 len1) (PS fp2 off2 len2)--- | len1 == 0 && len2 == 0 = EQ -- short cut for empty strings--- | fp1 == fp2 && off1 == off2 && len1 == len2 = EQ -- short cut for the same string- | otherwise = inlinePerformIO $- withForeignPtr fp1 $ \p1 ->- withForeignPtr fp2 $ \p2 ->- cmp (p1 `plusPtr` off1)- (p2 `plusPtr` off2) 0 len1 len2---- XXX todo.-cmp :: Ptr Word8 -> Ptr Word8 -> Int -> Int -> Int-> IO Ordering-cmp p1 p2 n len1 len2- | n == len1 = if n == len2 then return EQ else return LT- | n == len2 = return GT- | otherwise = do- a <- peekByteOff p1 n :: IO Word8- b <- peekByteOff p2 n- case a `compare` b of- EQ -> cmp p1 p2 (n+1) len1 len2- LT -> return LT- GT -> return GT--}---- -------------------------------------------------------------------------------- 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--#if !defined(__GLASGOW_HASKELL__)--pack str = unsafeCreate (P.length str) $ \p -> go p str- where- go _ [] = return ()- go p (x:xs) = poke p x >> go (p `plusPtr` 1) xs -- less space than pokeElemOff--#else /* hack away */--pack str = unsafeCreate (P.length str) $ \(Ptr p) -> stToIO (go p 0# str)- where- go _ _ [] = return ()- go p i (W8# c:cs) = writeByte p i c >> go p (i +# 1#) cs-- writeByte p i c = ST $ \s# ->- case writeWord8OffAddr# p i c s# of s2# -> (# s2#, () #)--#endif---- | /O(n)/ Converts a 'ByteString' to a '[Word8]'.-unpack :: ByteString -> [Word8]--#if !defined(__GLASGOW_HASKELL__)--unpack (PS _ _ 0) = []-unpack (PS ps s l) = inlinePerformIO $ withForeignPtr ps $ \p ->- go (p `plusPtr` s) (l - 1) []- where- STRICT3(go)- go p 0 acc = peek p >>= \e -> return (e : acc)- go p n acc = peekByteOff p n >>= \e -> go p (n-1) (e : acc)-{-# INLINE unpack #-}--#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 #-}--unpackList :: ByteString -> [Word8]-unpackList (PS fp off len) = withPtr fp $ \p -> do- let STRICT3(loop)- loop _ (-1) acc = return acc- loop q n acc = do- a <- peekByteOff q n- loop q (n-1) (a : acc)- loop (p `plusPtr` off) (len-1) []--{-# RULES-"ByteString unpack-list" [1] forall p .- unpackFoldr p (:) [] = unpackList 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 #-}------------------------------------------------------------------------------ | /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 xs ys | null xs = ys- | null ys = xs- | otherwise = concat [xs,ys]-{-# INLINE append #-}---- ------------------------------------------------------------------------ Transformations---- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each--- element of @xs@. This function is subject to array fusion.-map :: (Word8 -> Word8) -> ByteString -> ByteString-map f (PS fp s len) = inlinePerformIO $ 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.------ This function is subject to array fusion.----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'.--- This function is subject to array fusion. --- 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 [] = empty-concat [ps] = ps-concat xs = unsafeCreate len $ \ptr -> go xs ptr- where len = P.sum . P.map length $ xs- STRICT2(go)- go [] _ = return ()- go (PS p s l:ps) ptr = do- withForeignPtr p $ \fp -> memcpy ptr (fp `plusPtr` s) (fromIntegral l)- go ps (ptr `plusPtr` l)---- | 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) = inlinePerformIO $ 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) = inlinePerformIO $ 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) = inlinePerformIO $ 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) = inlinePerformIO $ 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':------ > snd (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. This function is subject to array fusion.-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)------- | 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) = inlinePerformIO $- 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) =- moduleError "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 ()--#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'.----#if defined(__GLASGOW_HASKELL__)-hPutNonBlocking :: Handle -> ByteString -> IO ByteString-hPutNonBlocking h bs@(PS ps s l) = do- bytesWritten <- withForeignPtr ps $ \p-> hPutBufNonBlocking h (p `plusPtr` s) l- return $! drop bytesWritten bs-#else-hPutNonBlocking :: Handle -> B.ByteString -> IO Int-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. Files are read using 'binary mode' on Windows,--- for 'text mode' use the Char8 version of this function.----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 ("Data.ByteString." ++ fun ++ ':':' ':msg)-{-# NOINLINE moduleError #-}---- 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\\\"\", \"λ-wörld\"]++table :: Table+table = [map StringC strings, map IntC [-3..3]]+@++The expression @encodeUtf8CSV table@ results in the following lazy+'L.LazyByteString'.++>Chunk "\"hello\",\"\\\"1\\\"\",\"\206\187-w\195\182rld\"\n-3,-2,-1,0,1,2,3\n" Empty++We can clearly see that we are converting to a /binary/ format. The \'λ\'+and \'ö\' characters, which have a Unicode codepoint above 127, are+expanded to their corresponding UTF-8 multi-byte representation.++We use the @criterion@ library (<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'+  + {-\# INLINE fixed2 \#-}+ fixed2 x = 'P.liftFixedToBounded' $ const x '>$<' 'P.char7' '>*<' 'P.char7'+@++The code should be mostly self-explanatory. The slightly awkward syntax is+because the combinators are written such that the size-bound of the resulting+'BoundedPrim' can be computed at compile time. We also explicitly inline the+@fixed2@ primitive, which encodes a fixed tuple of characters, to ensure that+the bound computation happens at compile time. When encoding the following list+of 'String's, the optimized implementation of @renderString@ is two times+faster.++@+maxiStrings :: [String]+maxiStrings = take 1000 $ cycle [\"hello\", \"\\\"1\\\"\", \"λ-wörld\"]+@++Most of the performance gain stems from using 'primMapListBounded', which+encodes a list of values from left-to-right with a 'BoundedPrim'. It exploits+the 'Builder' internals to avoid unnecessary function compositions (i.e.,+concatenations). In the future, we might expect the compiler to perform the+optimizations implemented in 'primMapListBounded'. However, it seems that the+code is currently to complicated for the compiler to see through. Therefore, we+provide the 'BoundedPrim' escape hatch, which allows data structures to provide+very efficient encoding traversals, like 'primMapListBounded' for lists.++Note that 'BoundedPrim's are a bit verbose, but quite versatile. Here is an+example of a 'BoundedPrim' for combined HTML escaping and UTF-8 encoding. It+exploits that the escaped character with the maximal Unicode codepoint is \'>\'.++@+{-\# INLINE charUtf8HtmlEscaped \#-}+charUtf8HtmlEscaped :: 'BoundedPrim' Char+charUtf8HtmlEscaped =+ 'condB' (> \'\>\' ) 'charUtf8' $+ 'condB' (== \'\<\' ) (fixed4 (\'&\',(\'l\',(\'t\',\';\')))) $ -- <+ 'condB' (== \'\>\' ) (fixed4 (\'&\',(\'g\',(\'t\',\';\')))) $ -- >+ 'condB' (== \'&\' ) (fixed5 (\'&\',(\'a\',(\'m\',(\'p\',\';\'))))) $ -- &+ 'condB' (== \'\"\' ) (fixed5 (\'&\',(\'\#\',(\'3\',(\'4\',\';\'))))) $ -- &\#34;+ 'condB' (== \'\\\'\') (fixed5 (\'&\',(\'\#\',(\'3\',(\'9\',\';\'))))) $ -- &\#39;+ ('liftFixedToBounded' 'char7') -- fallback for 'Char's smaller than \'\>\'+ where+ {-\# INLINE fixed4 \#-}+ fixed4 x = 'liftFixedToBounded' $ const x '>$<'+ char7 '>*<' char7 '>*<' char7 '>*<' char7+  + {-\# INLINE fixed5 \#-}+ fixed5 x = 'liftFixedToBounded' $ const x '>$<'+ char7 '>*<' char7 '>*<' char7 '>*<' char7 '>*<' char7+@++This module currently does not expose functions that require the special+properties of fixed-size primitives. They are useful for prefixing 'Builder's+with their size or for implementing chunked encodings. We will expose the+corresponding functions in future releases of this library.+-}++++{-+--+--+-- A /bounded primitive/ is a builder primitive that never results in a sequence+-- longer than some fixed number of bytes. This number of bytes must be+-- independent of the value being encoded. Typical examples of bounded+-- primitives are the big-endian encoding of a 'Word64', which results always+-- in exactly 8 bytes, or the UTF-8 encoding of a 'Char', which results always+-- in less or equal to 4 bytes.+--+-- Typically, primitives are implemented efficiently by allocating a buffer (an+-- array of bytes) and repeatedly executing the following two steps: (1)+-- writing to the buffer until it is full and (2) handing over the filled part+-- to the consumer of the encoded value. Step (1) is where bounded primitives+-- are used. We must use a bounded primitive, as we must check that there is+-- enough free space /before/ actually writing to the buffer.+--+-- In term of expressiveness, it would be sufficient to construct all encodings+-- from the single bounded encoding that encodes a 'Word8' as-is. However,+-- this is not sufficient in terms of efficiency. It results in unnecessary+-- buffer-full checks and it complicates the program-flow for writing to the+-- buffer, as buffer-full checks are interleaved with analysing the value to be+-- encoded (e.g., think about the program-flow for UTF-8 encoding). This has a+-- significant effect on overall encoding performance, as encoding primitive+-- Haskell values such as 'Word8's or 'Char's lies at the heart of every+-- encoding implementation.+--+-- The bounded 'Encoding's provided by this module remove this performance+-- problem. Intuitively, they consist of a tuple of the bound on the maximal+-- number of bytes written and the actual implementation of the encoding as a+-- function that modifies a mutable buffer. Hence when executing a bounded+-- 'Encoding', the buffer-full check can be done once before the actual writing+-- to the buffer. The provided 'Encoding's also take care to implement the+-- actual writing to the buffer efficiently. Moreover, combinators are+-- provided to construct new bounded encodings from the provided ones.+--+-- A typical example for using the combinators is a bounded 'Encoding' that+-- combines escaping the ' and \\ characters with UTF-8 encoding. More+-- precisely, the escaping to be done is the one implemented by the following+-- @escape@ function.+--+-- > escape :: Char -> [Char]+-- > escape '\'' = "\\'"+-- > escape '\\' = "\\\\"+-- > escape c = [c]+--+-- The bounded 'Encoding' that combines this escaping with UTF-8 encoding is+-- the following.+--+-- > import Data.ByteString.Builder.Prim.Utf8 (char)+-- >+-- > {-# INLINE escapeChar #-}+-- > escapeUtf8 :: BoundedPrim Char+-- > escapeUtf8 =+-- > encodeIf ('\'' ==) (char <#> char #. const ('\\','\'')) $+-- > encodeIf ('\\' ==) (char <#> char #. const ('\\','\\')) $+-- > char+--+-- The definition of 'escapeUtf8' is more complicated than 'escape', because+-- the combinators ('encodeIf', 'encodePair', '#.', and 'char') used in+-- 'escapeChar' compute both the bound on the maximal number of bytes written+-- (8 for 'escapeUtf8') as well as the low-level buffer manipulation required+-- to implement the encoding. Bounded 'Encoding's should always be inlined.+-- Otherwise, the compiler cannot compute the bound on the maximal number of+-- bytes written at compile-time. Without inlinining, it would also fail to+-- optimize the constant encoding of the escape characters in the above+-- example. Functions that execute bounded 'Encoding's also perform+-- suboptimally, if the definition of the bounded 'Encoding' is not inlined.+-- Therefore we add an 'INLINE' pragma to 'escapeUtf8'.+--+-- Currently, the only library that executes bounded 'Encoding's is the+-- 'bytestring' library (<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,19 +1,18 @@-{-# LANGUAGE CPP #-}--- We cannot actually specify all the language pragmas, see ghc ticket #--- If we could, these are what they would be:-{- LANGUAGE MagicHash, UnboxedTuples -}-{-# 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+-- (c) Duncan Coutts 2006-2011 -- License : BSD-style ----- Maintainer : dons@cse.unsw.edu.au--- Stability : experimental+-- Maintainer : dons00@gmail.com, duncan@community.haskell.org+-- Stability : stable -- Portability : portable -- -- Manipulate 'ByteString's using 'Char' operations. All Chars will be@@ -23,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>@@ -35,197 +34,228 @@ -- This module is intended to be imported @qualified@, to avoid name -- clashes with "Prelude" functions. eg. ----- > import qualified Data.ByteString.Char8 as B+-- > import qualified Data.ByteString.Char8 as C -- -- The Char8 interface to bytestrings provides an instance of IsString -- for the ByteString type, enabling you to use string literals, and--- have them implicitly packed to ByteStrings. Use -XOverloadedStrings--- to enable this.+-- have them implicitly packed to ByteStrings.+-- Use @{-\# LANGUAGE OverloadedStrings \#-}@ to enable this. -- 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+ -- or newline conversion. The fact that it does not respect the Handle+ -- 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) @@ -234,54 +264,34 @@ 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 (ByteString(PS), c2w, w2c, isSpaceWord8- ,inlinePerformIO)+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 -#if defined(__GLASGOW_HASKELL__)-import GHC.Base (Char(..),unpackCString#,ord#,int2Word#)-#if __GLASGOW_HASKELL__ >= 611-import GHC.IO (stToIO)-#else-import GHC.IOBase (stToIO)-#endif-import GHC.Prim (Addr#,writeWord8OffAddr#,plusAddr#)-import GHC.Ptr (Ptr(..))-import GHC.ST (ST(..))-#endif -#if MIN_VERSION_base(3,0,0)-import Data.String (IsString(..))-#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- ------------------------------------------------------------------------ -- | /O(1)/ Convert a 'Char' into a 'ByteString'@@ -289,48 +299,22 @@ singleton = B.singleton . c2w {-# INLINE singleton #-} -#if MIN_VERSION_base(3,0,0)-instance IsString ByteString where- fromString = pack- {-# INLINE fromString #-}-#endif- -- | /O(n)/ Convert a 'String' into a 'ByteString' -- -- For applications with large numbers of string literals, pack can be a -- bottleneck. pack :: String -> ByteString-#if !defined(__GLASGOW_HASKELL__)--pack str = B.unsafeCreate (P.length str) $ \p -> go p str- where go _ [] = return ()- go p (x:xs) = poke p (c2w x) >> go (p `plusPtr` 1) xs--#else /* hack away */--pack str = B.unsafeCreate (P.length str) $ \(Ptr p) -> stToIO (go p str)- where- go :: Addr# -> [Char] -> ST a ()- go _ [] = return ()- go p (C# c:cs) = writeByte p (int2Word# (ord# c)) >> go (p `plusAddr#` 1#) cs-- writeByte p c = ST $ \s# ->- case writeWord8OffAddr# p 0# c s# of s2# -> (# s2#, () #)- {-# INLINE writeByte #-}-{-# INLINE [1] pack #-}--{-# RULES-"ByteString pack/packAddress" forall s .- pack (unpackCString# s) = inlinePerformIO (B.unsafePackAddress s)- #-}--#endif+pack = packChars+{-# INLINE pack #-} -- | /O(n)/ Converts a 'ByteString' to a 'String'. unpack :: ByteString -> [Char]-unpack = P.map w2c . B.unpack+unpack = B.unpackChars {-# INLINE unpack #-} +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 :: Char -> ByteString -> ByteString@@ -351,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@@ -380,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' #-}@@ -389,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 #-}@@ -449,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)) @@ -490,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@@ -518,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 #-} @@ -529,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)@@ -583,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]@@ -645,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)@@ -654,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]@@ -671,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.@@ -683,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@@ -700,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.@@ -737,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@@ -800,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,@@ -811,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 @@ -835,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@@ -858,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@@ -897,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 = []@@ -908,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]@@ -943,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/Fusion.hs
@@ -1,24 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Safe #-}-#endif--- |--- Module : Data.ByteString.Fusion--- License : BSD-style--- Maintainer : dons@cse.unsw.edu.au--- Stability : experimental--- Portability : portable------ Stream fusion for ByteStrings.------ See the paper /Stream Fusion: From Lists to Streams to Nothing at All/,--- Coutts, Leshchinskiy and Stewart, 2007. -----module Data.ByteString.Fusion (-- -- A place holder for Stream Fusion-- ) where--
Data/ByteString/Internal.hs view
@@ -1,16 +1,13 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}--- We cannot actually specify all the language pragmas, see ghc ticket #--- If we could, these are what they would be:-{- LANGUAGE UnliftedFFITypes, MagicHash,- UnboxedTuples, DeriveDataTypeable -}-{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_HADDOCK not-home #-} -- | -- Module : Data.ByteString.Internal+-- Copyright : (c) Don Stewart 2006-2008+-- (c) Duncan Coutts 2006-2012 -- License : BSD-style--- Maintainer : Don Stewart <dons@galois.com>--- Stability : experimental--- Portability : portable+-- 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. As such@@ -23,384 +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+ ), - -- * Low level introduction and elimination- 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)+ 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,+ 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 -> CSize -> IO CInt- memcpy, -- :: Ptr Word8 -> Ptr Word8 -> CSize -> 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-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 611- -- * Internal GHC magic- memcpy_ptr_baoff, -- :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ())-#endif+ c_reverse,+ c_intersperse,+ c_maximum,+ c_minimum,+ c_count,+ c_sort, -- * Chars- w2c, c2w, isSpaceWord8, isSpaceChar8-- ) where--import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)-import Foreign.Ptr (Ptr, FunPtr, plusPtr)-import Foreign.Storable (Storable(..))-import Foreign.C.Types (CInt(..), CSize(..), CULong(..))-import Foreign.C.String (CString)--#ifndef __NHC__-import Control.Exception (assert)-#endif--import Data.Char (ord)-import Data.Word (Word8)--#if defined(__GLASGOW_HASKELL__)-import Data.Typeable (Typeable)-#if __GLASGOW_HASKELL__ >= 610-import Data.Data (Data)-#else-import Data.Generics (Data)-#endif-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 (Data, Typeable)-#endif--instance Show ByteString where- showsPrec p ps r = showsPrec p (unpackWith w2c ps) r--instance Read ByteString where- readsPrec p str = [ (packWith c2w x, y) | (x, y) <- readsPrec p str ]---- | /O(n)/ Converts a 'ByteString' to a '[a]', using a conversion function.-unpackWith :: (Word8 -> a) -> ByteString -> [a]-unpackWith _ (PS _ _ 0) = []-unpackWith k (PS ps s l) = inlinePerformIO $ withForeignPtr ps $ \p ->- go (p `plusPtr` s) (l - 1) []- where- STRICT3(go)- go p 0 acc = peek p >>= \e -> return (k e : acc)- go p n acc = peekByteOff p n >>= \e -> go p (n-1) (k e : acc)-{-# INLINE unpackWith #-}---- | /O(n)/ Convert a '[a]' into a 'ByteString' using some--- conversion function-packWith :: (a -> Word8) -> [a] -> ByteString-packWith k str = unsafeCreate (length str) $ \p -> go p str- where- STRICT2(go)- go _ [] = return ()- go p (x:xs) = poke p (k x) >> go (p `plusPtr` 1) xs -- less space than pokeElemOff-{-# INLINE packWith #-}------------------------------------------------------------------------------ | The 0 pointer. Used to indicate the empty Bytestring.-nullForeignPtr :: ForeignPtr Word8-#ifdef __GLASGOW_HASKELL__-nullForeignPtr = ForeignPtr nullAddr# undefined --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 #-}---- | 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 (fromIntegral 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) (fromIntegral 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 #-}------------------------------------------------------------------------------ | 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" memcmp- :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt--foreign import ccall unsafe "string.h memcpy" c_memcpy- :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)--memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO ()-memcpy p q s = c_memcpy p q 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--foreign import ccall unsafe "static fpstring.h fps_minimum" c_minimum- :: Ptr Word8 -> CULong -> IO Word8+ w2c, c2w, isSpaceWord8, isSpaceChar8, -foreign import ccall unsafe "static fpstring.h fps_count" c_count- :: Ptr Word8 -> CULong -> Word8 -> IO CULong+ -- * Deprecated and unmentionable+ accursedUnutterablePerformIO, --- ------------------------------------------------------------------------ Internal GHC Haskell magic+ -- * Exported compatibility shim+ plusForeignPtr,+ unsafeWithForeignPtr+ ) where -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 611-foreign import ccall unsafe "__hscore_memcpy_src_off"- memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ())-#endif+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,1371 +1,1790 @@-{-# LANGUAGE CPP #-}-{-# 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--- License : BSD-style------ Maintainer : dons@galois.com--- Stability : experimental--- 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. Byte vectors are encoded as lazy lists of strict 'Word8'--- arrays of bytes. They provide a means to manipulate large byte vectors--- without requiring the entire vector be resident in memory.------ 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. And for other--- operations lazy ByteStrings are usually within a few percent of--- strict ones, but with better heap usage. For data larger than the--- available memory, or if you have tight memory constraints, this--- module will be the only option. The default chunk size is 64k, which--- should be good in most circumstances. For people with large L2--- caches, you may want to increase this to fit your cache.------ 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.--- Polished and extended by Don Stewart.--- 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]- fromChunks, -- :: [Strict.ByteString] -> ByteString- toChunks, -- :: ByteString -> [Strict.ByteString]-- -- * 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---- -------------------------------------------------------------------------------instance Eq ByteString- where (==) = eq--instance Ord ByteString- where compare = cmp--instance Monoid ByteString where- mempty = empty- mappend = append- mconcat = concat--eq :: ByteString -> ByteString -> Bool-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--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)- 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- result -> result---- -------------------------------------------------------------------------------- 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 ws = L.foldr (Chunk . S.pack) Empty (chunks defaultChunkSize ws)- where- chunks :: Int -> [a] -> [[a]]- chunks _ [] = []- chunks size xs = case L.splitAt size xs of- (xs', xs'') -> xs' : chunks size xs''---- | /O(n)/ Converts a 'ByteString' to a '[Word8]'.-unpack :: ByteString -> [Word8]-unpack cs = L.concatMap S.unpack (toChunks cs)---TODO: we can do better here by integrating the concat with the unpack---- | /O(c)/ Convert a list of strict 'ByteString' into a lazy 'ByteString'-fromChunks :: [P.ByteString] -> ByteString-fromChunks cs = L.foldr chunk Empty cs---- | /O(n)/ Convert a lazy 'ByteString' into a list of strict 'ByteString'-toChunks :: ByteString -> [P.ByteString]-toChunks cs = foldrChunks (:) [] cs----------------------------------------------------------------------------{---- | /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 #-}---- | /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 xs ys = foldrChunks Chunk ys xs-{-# 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'.--- This function is subject to array fusion.-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 css0 = to css0- where- go Empty css = to css- go (Chunk c cs) css = Chunk c (go cs css)- to [] = Empty- to (cs:css) = go cs css---- | 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 Empty = []-group (Chunk c0 cs0) = group' [] (S.group c0) cs0- where - group' :: [P.ByteString] -> [P.ByteString] -> ByteString -> [ByteString]- group' acc@(s':_) ss@(s:_) cs- | S.unsafeHead s'- /= S.unsafeHead s = revNonEmptyChunks acc : group' [] ss cs- group' acc (s:[]) Empty = revNonEmptyChunks (s:acc) : []- group' acc (s:[]) (Chunk c cs) = group' (s:acc) (S.group c) cs- group' acc (s:ss) cs = revNonEmptyChunks (s:acc) : group' [] ss cs--{--TODO: check if something like this might be faster--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 _ Empty = []-groupBy k (Chunk c0 cs0) = groupBy' [] 0 (S.groupBy k c0) cs0- where- groupBy' :: [P.ByteString] -> Word8 -> [P.ByteString] -> ByteString -> [ByteString]- groupBy' acc@(_:_) c ss@(s:_) cs- | not (c `k` S.unsafeHead s) = revNonEmptyChunks acc : groupBy' [] 0 ss cs- groupBy' acc _ (s:[]) Empty = revNonEmptyChunks (s : acc) : []- groupBy' acc w (s:[]) (Chunk c cs) = groupBy' (s:acc) w' (S.groupBy k c) cs- where w' | L.null acc = S.unsafeHead s- | otherwise = w- groupBy' acc _ (s:ss) cs = revNonEmptyChunks (s : acc) : groupBy' [] 0 ss cs--{--TODO: check if something like this might be faster--groupBy :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString]-groupBy k xs- | null xs = []- | otherwise = take n xs : groupBy k (drop n xs)- where- n = 1 + findIndexOrEnd (not . k (head xs)) (tail 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 . (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"--moduleError :: String -> String -> a-moduleError fun msg = error ("Data.ByteString.Lazy." ++ fun ++ ':':' ':msg)----- 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/Char8.hs view
@@ -1,17 +1,16 @@-{-# 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+-- Copyright : (c) Don Stewart 2006-2008+-- (c) Duncan Coutts 2006-2011 -- License : BSD-style ----- Maintainer : dons@cse.unsw.edu.au--- Stability : experimental--- Portability : non-portable (imports Data.ByteString.Lazy)+-- Maintainer : dons00@gmail.com, duncan@community.haskell.org+-- Stability : stable+-- Portability : portable -- -- Manipulate /lazy/ 'ByteString's using 'Char' operations. All Chars will -- be truncated to 8 bits. It can be expected that these functions will@@ -23,209 +22,248 @@ -- -- > import qualified Data.ByteString.Lazy.Char8 as C --+-- The Char8 interface to bytestrings provides an instance of IsString+-- for the ByteString type, enabling you to use string literals, and+-- have them implicitly packed to ByteStrings.+-- Use @{-\# LANGUAGE OverloadedStrings \#-}@ to enable this.+-- 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]+ 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+ -- or newline conversion. The fact that it does not respect the Handle+ -- 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 +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--#if __GLASGOW_HASKELL__ >= 608-import Data.String (IsString(..))-#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) ------------------------------------------------------------------------ @@ -234,27 +272,23 @@ singleton = L.singleton . c2w {-# INLINE singleton #-} -#if __GLASGOW_HASKELL__ >= 608-instance IsString ByteString where- fromString = pack- {-# INLINE fromString #-}-#endif---- | /O(n)/ Convert a 'String' into a 'ByteString'. +-- | /O(n)/ Convert a 'String' into a 'ByteString'. pack :: [Char] -> ByteString-pack = L.pack. List.map c2w+pack = packChars -- | /O(n)/ Converts a 'ByteString' to a 'String'. unpack :: ByteString -> [Char]-unpack = List.map w2c . L.unpack-{-# INLINE unpack #-}+unpack = unpackChars --- | /O(1)/ 'cons' is analogous to '(:)' for lists.+infixr 5 `cons`, `cons'` --same as list (:)+infixl 5 `snoc`++-- | /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@@ -262,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.@@ -290,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@@ -314,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' #-}@@ -323,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) @@ -342,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)@@ -373,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, ...] --@@ -383,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@@ -440,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)@@ -468,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"@@ -488,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]@@ -508,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)@@ -522,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.@@ -529,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]@@ -541,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 --@@ -573,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@@ -650,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@@ -747,132 +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'. Use 'text mode'--- on Windows to interpret newlines-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,16 +1,19 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}--- We cannot actually specify all the language pragmas, see ghc ticket #--- If we could, these are what they would be:-{- LANGUAGE DeriveDataTypeable -}-{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE Unsafe #-} +{-# OPTIONS_HADDOCK not-home #-}++{-# LANGUAGE TypeFamilies #-}+ -- | -- Module : Data.ByteString.Lazy.Internal+-- Copyright : (c) Don Stewart 2006-2008+-- (c) Duncan Coutts 2006-2011 -- License : BSD-style--- Maintainer : dons@galois.com, duncan@haskell.org--- Stability : experimental--- Portability : portable--- +-- 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@@ -20,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,@@ -32,49 +36,171 @@ -- * Chunk allocation sizes defaultChunkSize, smallChunkSize,- chunkOverhead+ chunkOverhead, + -- * Conversion with lists: packing and unpacking+ packBytes, packChars,+ unpackBytes, unpackChars,+ -- * Conversions with strict ByteString+ fromStrict, toStrict,+ ) where -import qualified Data.ByteString.Internal as S+import Prelude hiding (concat) +import qualified Data.ByteString.Internal.Type as S++import Data.Word (Word8) import Foreign.Storable (Storable(sizeOf)) -#if defined(__GLASGOW_HASKELL__)-import Data.Typeable (Typeable)-#if __GLASGOW_HASKELL__ >= 610-import Data.Data (Data)-#else-import Data.Generics (Data)-#endif+import Data.Semigroup (Semigroup (..))+import Data.List.NonEmpty (NonEmpty ((:|)))+import Control.DeepSeq (NFData, rnf)++import Data.String (IsString(..))++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- deriving (Show, Read-#if defined(__GLASGOW_HASKELL__)- ,Data, Typeable+#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.)++ -- 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 = (<>)+ mconcat = concat++instance NFData ByteString where+ rnf Empty = ()+ rnf (Chunk _ b) = rnf b++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+ 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 lazy ByteString"+ dataTypeOf _ = byteStringDataType++packConstr :: Constr+packConstr = mkConstr byteStringDataType "pack" [] Prefix++byteStringDataType :: DataType+byteStringDataType = mkNoRepType "Data.ByteString.Lazy.ByteString"+ ------------------------------------------------------------------------+-- Packing and unpacking from lists +packBytes :: [Word8] -> ByteString+packBytes cs0 =+ packChunks 32 cs0+ where+ packChunks n cs = case S.packUptoLenBytes n cs of+ (bs, []) -> chunk bs Empty+ (bs, cs') -> Chunk bs (packChunks (min (n * 2) smallChunkSize) cs')++packChars :: [Char] -> ByteString+packChars cs0 = packChunks 32 cs0+ where+ packChunks n cs = case S.packUptoLenChars n cs of+ (bs, []) -> chunk bs Empty+ (bs, cs') -> Chunk bs (packChunks (min (n * 2) smallChunkSize) cs')++unpackBytes :: ByteString -> [Word8]+unpackBytes Empty = []+unpackBytes (Chunk c cs) = S.unpackAppendBytesLazy c (unpackBytes cs)++unpackChars :: ByteString -> [Char]+unpackChars Empty = []+unpackChars (Chunk c cs) = S.unpackAppendCharsLazy c (unpackChars cs)++------------------------------------------------------------------------++-- 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)@@ -82,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)@@ -96,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 #-} ------------------------------------------------------------------------@@ -116,12 +241,12 @@ -- The following value assumes people have something greater than 128k, -- and need to share the cache with other programs. --- | Currently set to 32k, less the memory management overhead+-- | The chunk size used for I\/O. Currently set to 32k, less the memory management overhead defaultChunkSize :: Int defaultChunkSize = 32 * k - chunkOverhead where k = 1024 --- | Currently set to 4k, less the memory management overhead+-- | The recommended chunk size. Currently set to 4k, less the memory management overhead smallChunkSize :: Int smallChunkSize = 4 * k - chunkOverhead where k = 1024@@ -129,3 +254,99 @@ -- | The memory management overhead. Currently this is tuned for GHC only. chunkOverhead :: Int chunkOverhead = 2 * sizeOf (undefined :: Int)++------------------------------------------------------------------------+-- Implementations for Eq, Ord and Monoid instances++eq :: ByteString -> ByteString -> Bool+eq Empty Empty = True+eq Empty _ = False+eq _ Empty = False+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@(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.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 = 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,14 +1,13 @@-{-# LANGUAGE CPP #-}--- We cannot actually specify all the language pragmas, see ghc ticket #--- If we could, these are what they would be:-{- LANGUAGE MagicHash -}+{-# LANGUAGE Unsafe #-} -- | -- Module : Data.ByteString.Unsafe+-- Copyright : (c) Don Stewart 2006-2008+-- (c) Duncan Coutts 2006-2011 -- License : BSD-style--- Maintainer : dons@cse.unsw.edu.au, duncan@haskell.org--- Stability : experimental--- Portability : portable+-- Maintainer : dons00@gmail.com, duncan@community.haskell.org+-- Stability : provisional+-- Portability : non-portable -- -- A module containing unsafe 'ByteString' operations. --@@ -19,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) -- --------------------------------------------------------------------- --@@ -96,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. --@@ -172,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@@ -191,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,6 +1,8 @@ Copyright (c) Don Stewart 2005-2009- (c) Duncan Coutts 2006-2009- (c) David Roundy 2003-2005.+ (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++[](https://github.com/haskell/bytestring/actions?query=workflow%3Aci) [](https://hackage.haskell.org/package/bytestring) [](http://stackage.org/lts/package/bytestring) [](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
@@ -0,0 +1,583 @@+-- |+-- Copyright : (c) 2011 Simon Meier+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Simon Meier <iridcode@gmail.com>+-- Stability : experimental+-- Portability : tested on GHC only+--++module Main (main) where++import Data.Foldable (foldMap)+import Data.Monoid+import Data.Semigroup+import Data.String+import Test.Tasty.Bench++import Prelude hiding (words)+import qualified Data.List as List+import Control.DeepSeq+import Control.Exception++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 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+------------------------------------------------------------------------------++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]++{-# 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++{-# NOINLINE doubleData #-}+doubleData :: [Double]+doubleData = map (\x -> (3.14159 * fromIntegral x) ^ (3 :: Int)) intData++{-# NOINLINE byteStringData #-}+byteStringData :: S.ByteString+byteStringData = S.pack $ map fromIntegral intData++{-# NOINLINE lazyByteStringData #-}+lazyByteStringData :: L.ByteString+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+---------------------++benchB :: String -> a -> (a -> Builder) -> Benchmark+{-# 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 'FixedPrim'. Full inlining to enable specialization.+{-# INLINE benchFE #-}+benchFE :: String -> FixedPrim Int -> Benchmark+benchFE name = benchBE name . P.liftFixedToBounded++-- | Benchmark a 'BoundedPrim'. Full inlining to enable specialization.+{-# INLINE benchBE #-}+benchBE :: String -> BoundedPrim Int -> Benchmark+benchBE name 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+ -> 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)++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+-------------++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+ 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 "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 "byteStringHex" byteStringData $ byteStringHex+ , benchB "lazyByteStringHex" lazyByteStringData $ lazyByteStringHex+ , benchB "foldMap floatDec" floatData $ foldMap floatDec+ , benchB "foldMap doubleDec" doubleData $ foldMap doubleDec+ -- 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.Builder.Prim"+ [ benchFE "char7" $ toEnum >$< P.char7+ , benchFE "char8" $ toEnum >$< P.char8+ , benchBE "charUtf8" $ toEnum >$< P.charUtf8++ -- binary encoding+ , benchFE "int8" $ fromIntegral >$< P.int8+ , benchFE "word8" $ fromIntegral >$< P.word8++ -- big-endian+ , benchFE "int16BE" $ fromIntegral >$< P.int16BE+ , benchFE "int32BE" $ fromIntegral >$< P.int32BE+ , benchFE "int64BE" $ fromIntegral >$< P.int64BE++ , benchFE "word16BE" $ fromIntegral >$< P.word16BE+ , benchFE "word32BE" $ fromIntegral >$< P.word32BE+ , benchFE "word64BE" $ fromIntegral >$< P.word64BE++ , benchFE "floatBE" $ fromIntegral >$< P.floatBE+ , benchFE "doubleBE" $ fromIntegral >$< P.doubleBE++ -- little-endian+ , benchFE "int16LE" $ fromIntegral >$< P.int16LE+ , benchFE "int32LE" $ fromIntegral >$< P.int32LE+ , benchFE "int64LE" $ fromIntegral >$< P.int64LE++ , benchFE "word16LE" $ fromIntegral >$< P.word16LE+ , benchFE "word32LE" $ fromIntegral >$< P.word32LE+ , benchFE "word64LE" $ fromIntegral >$< P.word64LE++ , benchFE "floatLE" $ fromIntegral >$< P.floatLE+ , benchFE "doubleLE" $ fromIntegral >$< P.doubleLE++ -- host-dependent+ , benchFE "int16Host" $ fromIntegral >$< P.int16Host+ , benchFE "int32Host" $ fromIntegral >$< P.int32Host+ , benchFE "int64Host" $ fromIntegral >$< P.int64Host+ , benchFE "intHost" $ fromIntegral >$< P.intHost++ , benchFE "word16Host" $ fromIntegral >$< P.word16Host+ , benchFE "word32Host" $ fromIntegral >$< P.word32Host+ , benchFE "word64Host" $ fromIntegral >$< P.word64Host+ , benchFE "wordHost" $ fromIntegral >$< P.wordHost++ , benchFE "floatHost" $ fromIntegral >$< P.floatHost+ , benchFE "doubleHost" $ fromIntegral >$< P.doubleHost+ ]++ , bgroup "Data.ByteString.Builder.Prim.ASCII"+ [+ -- decimal number+ 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 >$< 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 >$< 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 >$< P.int8HexFixed+ , benchFE "int16HexFixed" $ fromIntegral >$< P.int16HexFixed+ , benchFE "int32HexFixed" $ fromIntegral >$< P.int32HexFixed+ , benchFE "int64HexFixed" $ fromIntegral >$< P.int64HexFixed++ , benchFE "word8HexFixed" $ fromIntegral >$< P.word8HexFixed+ , benchFE "word16HexFixed" $ fromIntegral >$< P.word16HexFixed+ , benchFE "word32HexFixed" $ fromIntegral >$< P.word32HexFixed+ , benchFE "word64HexFixed" $ fromIntegral >$< P.word64HexFixed++ , 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+ ]+ ]
bytestring.cabal view
@@ -1,91 +1,253 @@+Cabal-Version: 2.2+ Name: bytestring-Version: 0.9.2.1-Synopsis: Fast, packed, strict and lazy byte arrays with a list interface+Version: 0.12.2.0+Synopsis: Fast, compact, strict and lazy byte strings with a list interface Description:- 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, and lazy lists of- strict chunks, held in a 'ForeignPtr', and can be passed between C- and Haskell with little effort.+ An efficient compact, immutable byte string type (both strict and lazy)+ suitable for binary or 8-bit character data. .- Test coverage data for this library is available at:- <http://code.haskell.org/~dons/tests/bytestring/hpc_index.html>+ 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 'ByteString' functions follow+ the same style as Haskell\'s ordinary lists, so it is easy to convert code+ from using 'String' to 'ByteString'.+ .+ Two 'ByteString' variants are provided:+ .+ * Strict 'ByteString's keep the string as a single large array. This+ makes them convenient for passing data between C and Haskell.+ .+ * Lazy 'ByteString's use a lazy list of strict chunks which makes it+ suitable for I\/O streaming tasks.+ .+ The @Char8@ modules provide a character-based view of the same+ underlying 'ByteString' types. This makes it convenient to handle mixed+ binary and 8-bit character content (which is common in many file formats+ and network protocols).+ .+ The 'Builder' module provides an efficient way to build up 'ByteString's+ 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.+ .+ These modules are intended to be imported qualified, to avoid name clashes+ with "Prelude" functions, e.g.+ .+ > 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-2009,- (c) David Roundy 2003-2005.-Author: Don Stewart, Duncan Coutts-Maintainer: dons00@gmail.com, duncan@community.haskell.org-Homepage: http://www.cse.unsw.edu.au/~dons/fps.html-Tested-With: GHC==7.0.2, GHC==6.12.3, GHC==6.10.4, GHC ==6.8.2+Copyright: Copyright (c) Don Stewart 2005-2009,+ (c) Duncan Coutts 2006-2015,+ (c) David Roundy 2003-2005,+ (c) Jasper Van der Jeugt 2010,+ (c) Simon Meier 2010-2013.++Author: Don Stewart,+ Duncan Coutts+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: git+ location: https://github.com/haskell/bytestring+++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+ library- build-depends: base >= 3 && < 5+ import: language+ build-depends: base >= 4.11 && < 5, ghc-prim, deepseq, template-haskell - if impl(ghc >= 6.10)- build-depends: ghc-prim, base >= 4+ if impl(ghc < 9.4)+ build-depends: data-array-byte >= 0.1 && < 0.2 - 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.Fusion+ 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+ Data.ByteString.Builder+ Data.ByteString.Builder.Extra+ Data.ByteString.Builder.Prim+ Data.ByteString.Builder.RealFloat - if impl(ghc)- extensions: UnliftedFFITypes,- MagicHash,- UnboxedTuples,- DeriveDataTypeable- ScopedTypeVariables- if impl(ghc >= 6.11)- extensions: NamedFieldPuns+ -- 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 - --TODO: eliminate orphan instances:- ghc-options: -Wall -fno-warn-orphans- -O2- -funbox-strict-fields - -fmax-simplifier-iterations10- -fdicts-cheap+ ghc-options: -Wall -fwarn-tabs -Wincomplete-uni-patterns+ -optP-Wall -optP-Werror=undef+ -O2+ -fmax-simplifier-iterations=10+ -fdicts-cheap+ -fspec-constr-count=6 - c-sources: cbits/fpstring.c+ 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++ c-sources: cbits/fpstring.c+ cbits/itoa.c+ cbits/shortbytestring.c+ cbits/aligned-static-hs-data.c++ if (arch(aarch64))+ c-sources: cbits/aarch64/is-valid-utf8.c+ else+ c-sources: cbits/is-valid-utf8.c++ -- DNDEBUG disables asserts in cbits/+ cc-options: -std=c11 -DNDEBUG=1+ -fno-strict-aliasing+ -Werror=undef++ -- 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++ 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+ include-dirs: include- includes: fpstring.h install-includes: fpstring.h+ bytestring-cpp-macros.h - nhc98-options: -K4M -K3M+test-suite bytestring-tests+ import: language+ type: exitcode-stdio-1.0+ 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 --- QC properties, with GHC RULES disabled-test-suite prop-compiled+ 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- main-is: Properties.hs- hs-source-dirs: . tests- build-depends: base, random, directory,- QuickCheck >= 2.3 && < 3- if impl(ghc >= 6.10)- build-depends: ghc-prim- c-sources: cbits/fpstring.c- include-dirs: include- if impl(ghc >= 6.10)- ghc-options: -fno-enable-rewrite-rules- else- ghc-options: -fno-rewrite-rules- if impl(ghc)- extensions: UnliftedFFITypes,- MagicHash,- UnboxedTuples,- DeriveDataTypeable- ScopedTypeVariables- if impl(ghc >= 6.11)- extensions: NamedFieldPuns+ hs-source-dirs: bench++ 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
@@ -0,0 +1,215 @@+///////////////////////////////////////////////////////////////+// Encoding numbers using ASCII characters //+// //+// inspired by: http://www.jb.man.ac.uk/~slowe/cpp/itoa.html //+///////////////////////////////////////////////////////////////++#include <stdio.h>++// Decimal Encoding+///////////////////++static const char* digits = "0123456789abcdef";++// signed integers+char* _hs_bytestring_int_dec (int x, char* buf)+{+ char c, *ptr = buf, *next_free;+ int x_tmp;++ // we cannot negate directly as 0 - (minBound :: Int) = minBound+ if (x < 0) {+ *ptr++ = '-';+ buf++;+ x_tmp = x;+ x /= 10;+ *ptr++ = digits[x * 10 - x_tmp];+ if (x == 0)+ return ptr;+ else+ x = -x;+ }++ // encode positive number as little-endian decimal+ do {+ x_tmp = x;+ x /= 10;+ *ptr++ = digits[x_tmp - x * 10];+ } while ( x );++ // reverse written digits+ next_free = ptr--;+ while (buf < ptr) {+ c = *ptr;+ *ptr-- = *buf;+ *buf++ = c;+ }+ return next_free;+}++// signed long long ints (64 bit integers)+char* _hs_bytestring_long_long_int_dec (long long int x, char* buf)+{+ char c, *ptr = buf, *next_free;+ long long int x_tmp;++ // we cannot negate directly as 0 - (minBound :: Int) = minBound+ if (x < 0) {+ *ptr++ = '-';+ buf++;+ x_tmp = x;+ x /= 10;+ *ptr++ = digits[x * 10 - x_tmp];+ if (x == 0)+ return ptr;+ else+ x = -x;+ }++ // encode positive number as little-endian decimal+ do {+ x_tmp = x;+ x /= 10;+ *ptr++ = digits[x_tmp - x * 10];+ } while ( x );++ // reverse written digits+ next_free = ptr--;+ while (buf < ptr) {+ c = *ptr;+ *ptr-- = *buf;+ *buf++ = c;+ }+ return next_free;+}++// unsigned integers+char* _hs_bytestring_uint_dec (unsigned int x, char* buf)+{+ char c, *ptr = buf, *next_free;+ unsigned int x_tmp;++ // encode positive number as little-endian decimal+ do {+ x_tmp = x;+ x /= 10;+ *ptr++ = digits[x_tmp - x * 10];+ } while ( x );++ // reverse written digits+ next_free = ptr--;+ while (buf < ptr) {+ c = *ptr;+ *ptr-- = *buf;+ *buf++ = c;+ }+ return next_free;+}++// unsigned long ints+char* _hs_bytestring_long_long_uint_dec (long long unsigned int x, char* buf)+{+ char c, *ptr = buf, *next_free;+ long long unsigned int x_tmp;++ // encode positive number as little-endian decimal+ do {+ x_tmp = x;+ x /= 10;+ *ptr++ = digits[x_tmp - x * 10];+ } while ( x );++ // reverse written digits+ next_free = ptr--;+ while (buf < ptr) {+ c = *ptr;+ *ptr-- = *buf;+ *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'; }+}+++///////////////////////+// Hexadecimal encoding+///////////////////////++// unsigned ints (32 bit words)+char* _hs_bytestring_uint_hex (unsigned int x, char* buf) {+ // write hex representation in reverse order+ char c, *ptr = buf, *next_free;+ do {+ *ptr++ = digits[x & 0xf];+ x >>= 4;+ } while ( x );+ // invert written digits+ next_free = ptr--;+ while(buf < ptr) {+ c = *ptr;+ *ptr-- = *buf;+ *buf++ = c;+ }+ return next_free;+};++// unsigned long ints (64 bit words)+char* _hs_bytestring_long_long_uint_hex (long long unsigned int x, char* buf) {+ // write hex representation in reverse order+ char c, *ptr = buf, *next_free;+ do {+ *ptr++ = digits[x & 0xf];+ x >>= 4;+ } while ( x );+ // invert written digits+ next_free = ptr--;+ while(buf < ptr) {+ c = *ptr;+ *ptr-- = *buf;+ *buf++ = c;+ }+ return next_free;+};
+ 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,6 +1,9 @@+#include <string.h>+#include <stdlib.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);+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,2348 +1,750 @@-{-# LANGUAGE PatternSignatures #-}------ 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-import Foreign.ForeignPtr-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 Debug.Trace-import Data.String--import System.Environment-import System.IO-import System.IO.Unsafe-import System.Random--import Foreign.Ptr--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 LP-import Data.ByteString.Fusion-import Prelude hiding (abs)--import Rules-import QuickCheckUtils--f = C.dropWhile isSpace------- 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_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_unconsCC = D.uncons `eq1` C.uncons-prop_countCC = D.count `eq2` C.count-prop_dropCC = D.drop `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` C.findIndex-prop_findIndicesCC = D.findIndices `eq2` C.findIndices-prop_isPrefixOfCC = D.isPrefixOf `eq2` C.isPrefixOf-prop_mapCC = D.map `eq2` C.map-prop_replicateCC = forAll arbitrarySizedIntegral $- D.replicate `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 `eq2` C.splitAt-prop_takeCC = D.take `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` C.elemIndex-prop_elemIndicesCC = D.elemIndices `eq2` C.elemIndices-prop_lengthCC = D.length `eq1` (fromIntegral . C.length :: C.ByteString -> Int64)--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_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_consLP' = LC.cons' `eq2` P.cons-prop_unconsBP = L.uncons `eq1` P.uncons-prop_countBP = L.count `eq2` P.count-prop_dropBP = L.drop `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` P.findIndex-prop_findIndicesBP = L.findIndices `eq2` P.findIndices-prop_isPrefixOfBP = L.isPrefixOf `eq2` P.isPrefixOf-prop_mapBP = L.map `eq2` P.map-prop_replicateBP = forAll arbitrarySizedIntegral $- L.replicate `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 `eq2` P.splitAt-prop_takeBP = L.take `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` P.elemIndex-prop_elemIndicesBP = L.elemIndices `eq2` P.elemIndices-prop_intersperseBP = L.intersperse `eq2` P.intersperse-prop_lengthBP = L.length `eq1` (fromIntegral . P.length :: P.ByteString -> Int64)-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` (length :: [W] -> Int)-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_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 `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` (findIndices:: (W -> Bool) -> [W] -> [Int])-prop_findIndexBL = L.findIndex `eq2` (findIndex :: (W -> Bool) -> [W] -> Maybe Int)-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 `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 `eq2` (splitAt :: Int -> [W] -> ([W],[W]))-prop_takeBL = L.take `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` (elemIndex :: W -> [W] -> Maybe Int)-prop_elemIndicesBL = L.elemIndices `eq2` (elemIndices:: W -> [W] -> [Int])-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_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 types = 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 types = 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_groupByCC 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_groupBy1CC 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-prop_isstring x = C.unpack (fromString x :: C.ByteString) == x-prop_isstring_lc x = LC.unpack (fromString x :: LC.ByteString) == x----------------------------------------------------------------------------- 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 = LP.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 = 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_show x = show x == show (C.unpack 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 = run tests--run :: [(String, Int -> IO (Bool,Int))] -> IO ()-run 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!"------- 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 =- [("readFile.writeFile", mytest prop_read_write_file_P)- ,("readFile.writeFile", mytest prop_read_write_file_C)- ,("readFile.writeFile", mytest prop_read_write_file_L)- ,("readFile.writeFile", mytest prop_read_write_file_D)-- ,("appendFile ", mytest prop_append_file_P)- ,("appendFile ", mytest prop_append_file_C)- ,("appendFile ", mytest prop_append_file_L)- ,("appendFile ", mytest prop_append_file_D)-- ,("packAddress ", mytest prop_packAddress)-- ]--misc_tests =- [("invariant", mytest prop_invariant)- ,("unsafe pack address", mytest prop_unsafePackAddress)- ,("unsafe pack address len",mytest prop_unsafePackAddressLen)- ,("unsafeUseAsCString", mytest prop_unsafeUseAsCString)- ,("unsafeUseAsCStringLen", mytest prop_unsafeUseAsCStringLen)- ,("useAsCString", mytest prop_useAsCString)- ,("packCString", mytest prop_packCString)- ,("packCString safe", mytest prop_packCString_safe)- ,("packCStringLen", mytest prop_packCStringLen)- ,("packCStringLen safe", mytest prop_packCStringLen_safe)- ,("packCStringFinaliser", mytest prop_packCStringFinaliser)- ,("packMallocString", mytest prop_packMallocCString)- ,("unsafeFinalise", mytest prop_unsafeFinalize)- ,("invariant", mytest prop_internal_invariant)- ,("show", mytest prop_show)- ,("fromForeignPtr", mytest prop_fromForeignPtr)- ]----------------------------------------------------------------------------- ByteString.Lazy <=> List--bl_tests =- [("all", mytest prop_allBL)- ,("any", mytest prop_anyBL)- ,("append", mytest prop_appendBL)- ,("compare", mytest prop_compareBL)- ,("concat", mytest prop_concatBL)- ,("cons", mytest prop_consBL)- ,("eq", mytest prop_eqBL)- ,("filter", mytest prop_filterBL)- ,("find", mytest prop_findBL)- ,("findIndex", mytest prop_findIndexBL)- ,("findIndices", mytest prop_findIndicesBL)- ,("foldl", mytest prop_foldlBL)- ,("foldl'", mytest prop_foldlBL')- ,("foldl1", mytest prop_foldl1BL)- ,("foldl1'", mytest prop_foldl1BL')- ,("foldr", mytest prop_foldrBL)- ,("foldr1", mytest prop_foldr1BL)- ,("mapAccumL", mytest prop_mapAccumLBL)- ,("mapAccumR", mytest prop_mapAccumRBL)- ,("mapAccumR", mytest prop_mapAccumRDL)- ,("mapAccumR", mytest prop_mapAccumRCC)- ,("unfoldr", mytest prop_unfoldrBL)- ,("unfoldr", mytest prop_unfoldrLC)- ,("unfoldr", mytest prop_cycleLC)- ,("iterate", mytest prop_iterateLC)- ,("iterate", mytest prop_iterateLC_2)- ,("iterate", mytest prop_iterateL)- ,("repeat", mytest prop_repeatLC)- ,("repeat", mytest prop_repeatL)- ,("head", mytest prop_headBL)- ,("init", mytest prop_initBL)- ,("isPrefixOf", mytest prop_isPrefixOfBL)- ,("last", mytest prop_lastBL)- ,("length", mytest prop_lengthBL)- ,("map", mytest prop_mapBL)- ,("maximum", mytest prop_maximumBL)- ,("minimum", mytest prop_minimumBL)- ,("null", mytest prop_nullBL)- ,("reverse", mytest prop_reverseBL)- ,("snoc", mytest prop_snocBL)- ,("tail", mytest prop_tailBL)- ,("transpose", mytest prop_transposeBL)- ,("replicate", mytest prop_replicateBL)- ,("take", mytest prop_takeBL)- ,("drop", mytest prop_dropBL)- ,("splitAt", mytest prop_splitAtBL)- ,("takeWhile", mytest prop_takeWhileBL)- ,("dropWhile", mytest prop_dropWhileBL)- ,("break", mytest prop_breakBL)- ,("span", mytest prop_spanBL)- ,("group", mytest prop_groupBL)- ,("inits", mytest prop_initsBL)- ,("tails", mytest prop_tailsBL)- ,("elem", mytest prop_elemBL)- ,("notElem", mytest prop_notElemBL)- ,("lines", mytest prop_linesBL)- ,("elemIndex", mytest prop_elemIndexBL)- ,("elemIndices", mytest prop_elemIndicesBL)- ,("concatMap", mytest prop_concatMapBL)- ]----------------------------------------------------------------------------- ByteString.Lazy <=> ByteString--cc_tests =- [("prop_concatCC", mytest prop_concatCC)- ,("prop_nullCC", mytest prop_nullCC)- ,("prop_reverseCC", mytest prop_reverseCC)- ,("prop_transposeCC", mytest prop_transposeCC)- ,("prop_groupCC", mytest prop_groupCC)- ,("prop_initsCC", mytest prop_initsCC)- ,("prop_tailsCC", mytest prop_tailsCC)- ,("prop_allCC", mytest prop_allCC)- ,("prop_anyCC", mytest prop_anyCC)- ,("prop_appendCC", mytest prop_appendCC)- ,("prop_breakCC", mytest prop_breakCC)- ,("prop_concatMapCC", mytest prop_concatMapCC)- ,("prop_consCC", mytest prop_consCC)- ,("prop_unconsCC", mytest prop_unconsCC)- ,("prop_countCC", mytest prop_countCC)- ,("prop_dropCC", mytest prop_dropCC)- ,("prop_dropWhileCC", mytest prop_dropWhileCC)- ,("prop_filterCC", mytest prop_filterCC)- ,("prop_findCC", mytest prop_findCC)- ,("prop_findIndexCC", mytest prop_findIndexCC)- ,("prop_findIndicesCC", mytest prop_findIndicesCC)- ,("prop_isPrefixOfCC", mytest prop_isPrefixOfCC)- ,("prop_mapCC", mytest prop_mapCC)- ,("prop_replicateCC", mytest prop_replicateCC)- ,("prop_snocCC", mytest prop_snocCC)- ,("prop_spanCC", mytest prop_spanCC)- ,("prop_splitCC", mytest prop_splitCC)- ,("prop_splitAtCC", mytest prop_splitAtCC)- ,("prop_takeCC", mytest prop_takeCC)- ,("prop_takeWhileCC", mytest prop_takeWhileCC)- ,("prop_elemCC", mytest prop_elemCC)- ,("prop_notElemCC", mytest prop_notElemCC)- ,("prop_elemIndexCC", mytest prop_elemIndexCC)- ,("prop_elemIndicesCC", mytest prop_elemIndicesCC)- ,("prop_lengthCC", mytest prop_lengthCC)- ,("prop_headCC", mytest prop_headCC)- ,("prop_initCC", mytest prop_initCC)- ,("prop_lastCC", mytest prop_lastCC)- ,("prop_maximumCC", mytest prop_maximumCC)- ,("prop_minimumCC", mytest prop_minimumCC)- ,("prop_tailCC", mytest prop_tailCC)- ,("prop_foldl1CC", mytest prop_foldl1CC)- ,("prop_foldl1CC'", mytest prop_foldl1CC')- ,("prop_foldr1CC", mytest prop_foldr1CC)- ,("prop_foldr1CC'", mytest prop_foldr1CC')- ,("prop_scanlCC", mytest prop_scanlCC)- ,("prop_intersperseCC", mytest prop_intersperseCC)-- ,("prop_foldlCC", mytest prop_foldlCC)- ,("prop_foldlCC'", mytest prop_foldlCC')- ,("prop_foldrCC", mytest prop_foldrCC)- ,("prop_foldrCC'", mytest prop_foldrCC')- ,("prop_mapAccumLCC", mytest prop_mapAccumLCC)--- ,("prop_mapIndexedCC", mytest prop_mapIndexedCC)--- ,("prop_mapIndexedPL", mytest prop_mapIndexedPL)-- ]--bp_tests =- [("all", mytest prop_allBP)- ,("any", mytest prop_anyBP)- ,("append", mytest prop_appendBP)- ,("compare", mytest prop_compareBP)- ,("concat", mytest prop_concatBP)- ,("cons", mytest prop_consBP)- ,("cons'", mytest prop_consBP')- ,("cons'", mytest prop_consLP')- ,("uncons", mytest prop_unconsBP)- ,("eq", mytest prop_eqBP)- ,("filter", mytest prop_filterBP)- ,("find", mytest prop_findBP)- ,("findIndex", mytest prop_findIndexBP)- ,("findIndices", mytest prop_findIndicesBP)- ,("foldl", mytest prop_foldlBP)- ,("foldl'", mytest prop_foldlBP')- ,("foldl1", mytest prop_foldl1BP)- ,("foldl1'", mytest prop_foldl1BP')- ,("foldr", mytest prop_foldrBP)- ,("foldr'", mytest prop_foldrBP')- ,("foldr1", mytest prop_foldr1BP)- ,("foldr1'", mytest prop_foldr1BP')- ,("mapAccumL", mytest prop_mapAccumLBP)--- ,("mapAccumL", mytest prop_mapAccumL_mapIndexedBP)- ,("unfoldr", mytest prop_unfoldrBP)- ,("unfoldr 2", mytest prop_unfoldr2BP)- ,("unfoldr 2", mytest prop_unfoldr2CP)- ,("head", mytest prop_headBP)- ,("init", mytest prop_initBP)- ,("isPrefixOf", mytest prop_isPrefixOfBP)- ,("last", mytest prop_lastBP)- ,("length", mytest prop_lengthBP)- ,("readInt", mytest prop_readIntBP)- ,("lines", mytest prop_linesBP)- ,("lines \\n", mytest prop_linesNLBP)- ,("map", mytest prop_mapBP)- ,("maximum ", mytest prop_maximumBP)- ,("minimum" , mytest prop_minimumBP)- ,("null", mytest prop_nullBP)- ,("reverse", mytest prop_reverseBP)- ,("snoc", mytest prop_snocBP)- ,("tail", mytest prop_tailBP)- ,("scanl", mytest prop_scanlBP)- ,("transpose", mytest prop_transposeBP)- ,("replicate", mytest prop_replicateBP)- ,("take", mytest prop_takeBP)- ,("drop", mytest prop_dropBP)- ,("splitAt", mytest prop_splitAtBP)- ,("takeWhile", mytest prop_takeWhileBP)- ,("dropWhile", mytest prop_dropWhileBP)- ,("break", mytest prop_breakBP)- ,("span", mytest prop_spanBP)- ,("split", mytest prop_splitBP)- ,("count", mytest prop_countBP)- ,("group", mytest prop_groupBP)- ,("inits", mytest prop_initsBP)- ,("tails", mytest prop_tailsBP)- ,("elem", mytest prop_elemBP)- ,("notElem", mytest prop_notElemBP)- ,("elemIndex", mytest prop_elemIndexBP)- ,("elemIndices", mytest prop_elemIndicesBP)- ,("intersperse", mytest prop_intersperseBP)- ,("concatMap", mytest prop_concatMapBP)- ]----------------------------------------------------------------------------- ByteString <=> List--pl_tests =- [("all", mytest prop_allPL)- ,("any", mytest prop_anyPL)- ,("append", mytest prop_appendPL)- ,("compare", mytest prop_comparePL)- ,("concat", mytest prop_concatPL)- ,("cons", mytest prop_consPL)- ,("eq", mytest prop_eqPL)- ,("filter", mytest prop_filterPL)- ,("filter rules",mytest prop_filterPL_rule)- ,("filter rules",mytest prop_filterLC_rule)- ,("partition", mytest prop_partitionPL)- ,("partition", mytest prop_partitionLL)- ,("find", mytest prop_findPL)- ,("findIndex", mytest prop_findIndexPL)- ,("findIndices", mytest prop_findIndicesPL)- ,("foldl", mytest prop_foldlPL)- ,("foldl'", mytest prop_foldlPL')- ,("foldl1", mytest prop_foldl1PL)- ,("foldl1'", mytest prop_foldl1PL')- ,("foldr1", mytest prop_foldr1PL)- ,("foldr", mytest prop_foldrPL)- ,("mapAccumL", mytest prop_mapAccumLPL)- ,("mapAccumR", mytest prop_mapAccumRPL)- ,("unfoldr", mytest prop_unfoldrPL)- ,("scanl", mytest prop_scanlPL)- ,("scanl1", mytest prop_scanl1PL)- ,("scanl1", mytest prop_scanl1CL)- ,("scanr", mytest prop_scanrCL)- ,("scanr", mytest prop_scanrPL)- ,("scanr1", mytest prop_scanr1PL)- ,("scanr1", mytest prop_scanr1CL)- ,("head", mytest prop_headPL)- ,("init", mytest prop_initPL)- ,("last", mytest prop_lastPL)- ,("maximum", mytest prop_maximumPL)- ,("minimum", mytest prop_minimumPL)- ,("tail", mytest prop_tailPL)- ,("zip", mytest prop_zipPL)- ,("zip", mytest prop_zipLL)- ,("zip", mytest prop_zipCL)- ,("unzip", mytest prop_unzipPL)- ,("unzip", mytest prop_unzipLL)- ,("unzip", mytest prop_unzipCL)- ,("zipWith", mytest prop_zipWithPL)--- ,("zipWith", mytest prop_zipWithCL)- ,("zipWith rules", mytest prop_zipWithPL_rules)--- ,("zipWith/zipWith'", mytest prop_zipWithPL')-- ,("isPrefixOf", mytest prop_isPrefixOfPL)- ,("isInfixOf", mytest prop_isInfixOfPL)- ,("length", mytest prop_lengthPL)- ,("map", mytest prop_mapPL)- ,("null", mytest prop_nullPL)- ,("reverse", mytest prop_reversePL)- ,("snoc", mytest prop_snocPL)- ,("transpose", mytest prop_transposePL)- ,("replicate", mytest prop_replicatePL)- ,("take", mytest prop_takePL)- ,("drop", mytest prop_dropPL)- ,("splitAt", mytest prop_splitAtPL)- ,("takeWhile", mytest prop_takeWhilePL)- ,("dropWhile", mytest prop_dropWhilePL)- ,("break", mytest prop_breakPL)- ,("span", mytest prop_spanPL)- ,("group", mytest prop_groupPL)- ,("inits", mytest prop_initsPL)- ,("tails", mytest prop_tailsPL)- ,("elem", mytest prop_elemPL)- ,("notElem", mytest prop_notElemPL)- ,("lines", mytest prop_linesPL)- ,("elemIndex", mytest prop_elemIndexPL)- ,("elemIndex", mytest prop_elemIndexCL)- ,("elemIndices", mytest prop_elemIndicesPL)- ,("concatMap", mytest prop_concatMapPL)- ,("IsString", mytest prop_isstring)- ,("IsString LC", mytest prop_isstring_lc)- ]----------------------------------------------------------------------------- extra ByteString properties--bb_tests =- [ ("bijection", mytest prop_bijectionBB)- , ("bijection'", mytest prop_bijectionBB')- , ("pack/unpack", mytest prop_packunpackBB)- , ("unpack/pack", mytest prop_packunpackBB')- , ("eq 1", mytest prop_eq1BB)- , ("eq 2", mytest prop_eq2BB)- , ("eq 3", mytest prop_eq3BB)- , ("compare 1", mytest prop_compare1BB)- , ("compare 2", mytest prop_compare2BB)- , ("compare 3", mytest prop_compare3BB)- , ("compare 4", mytest prop_compare4BB)- , ("compare 5", mytest prop_compare5BB)- , ("compare 6", mytest prop_compare6BB)- , ("compare 7", mytest prop_compare7BB)- , ("compare 7", mytest prop_compare7LL)- , ("compare 8", mytest prop_compare8BB)- , ("empty 1", mytest prop_nil1BB)- , ("empty 2", mytest prop_nil2BB)- , ("empty 1 monoid", mytest prop_nil1LL_monoid)- , ("empty 2 monoid", mytest prop_nil2LL_monoid)- , ("empty 1 monoid", mytest prop_nil1BB_monoid)- , ("empty 2 monoid", mytest prop_nil2BB_monoid)-- , ("null", mytest prop_nullBB)- , ("length 1", mytest prop_lengthBB)- , ("length 2", mytest prop_lengthSBB)- , ("cons 1", mytest prop_consBB)- , ("cons 2", mytest prop_cons1BB)- , ("cons 3", mytest prop_cons2BB)- , ("cons 4", mytest prop_cons3BB)- , ("cons 5", mytest prop_cons4BB)- , ("snoc", mytest prop_snoc1BB)- , ("head 1", mytest prop_head1BB)- , ("head 2", mytest prop_head2BB)- , ("head 3", mytest prop_head3BB)- , ("tail", mytest prop_tailBB)- , ("tail 1", mytest prop_tail1BB)- , ("last", mytest prop_lastBB)- , ("init", mytest prop_initBB)- , ("append 1", mytest prop_append1BB)- , ("append 2", mytest prop_append2BB)- , ("append 3", mytest prop_append3BB)- , ("mappend 1", mytest prop_append1BB_monoid)- , ("mappend 2", mytest prop_append2BB_monoid)- , ("mappend 3", mytest prop_append3BB_monoid)-- , ("map 1", mytest prop_map1BB)- , ("map 2", mytest prop_map2BB)- , ("map 3", mytest prop_map3BB)- , ("filter1", mytest prop_filter1BB)- , ("filter2", mytest prop_filter2BB)--- , ("map fusion", mytest prop_mapfusionBB)--- , ("filter fusion", mytest prop_filterfusionBB)- , ("reverse 1", mytest prop_reverse1BB)- , ("reverse 2", mytest prop_reverse2BB)- , ("reverse 3", mytest prop_reverse3BB)- , ("foldl 1", mytest prop_foldl1BB)- , ("foldl 2", mytest prop_foldl2BB)- , ("foldr 1", mytest prop_foldr1BB)- , ("foldr 2", mytest prop_foldr2BB)- , ("foldl1 1", mytest prop_foldl1_1BB)- , ("foldl1 2", mytest prop_foldl1_2BB)- , ("foldl1 3", mytest prop_foldl1_3BB)- , ("foldr1 1", mytest prop_foldr1_1BB)- , ("foldr1 2", mytest prop_foldr1_2BB)- , ("foldr1 3", mytest prop_foldr1_3BB)- , ("scanl/foldl", mytest prop_scanlfoldlBB)- , ("all", mytest prop_allBB)- , ("any", mytest prop_anyBB)- , ("take", mytest prop_takeBB)- , ("drop", mytest prop_dropBB)- , ("takeWhile", mytest prop_takeWhileBB)- , ("dropWhile", mytest prop_dropWhileBB)- , ("dropWhile", mytest prop_dropWhileCC_isSpace)- , ("splitAt", mytest prop_splitAtBB)- , ("span", mytest prop_spanBB)- , ("break", mytest prop_breakBB)- , ("elem", mytest prop_elemBB)- , ("notElem", mytest prop_notElemBB)-- , ("concat 1", mytest prop_concat1BB)- , ("concat 2", mytest prop_concat2BB)- , ("concat 3", mytest prop_concatBB)- , ("mconcat 1", mytest prop_concat1BB_monoid)- , ("mconcat 2", mytest prop_concat2BB_monoid)- , ("mconcat 3", mytest prop_concatBB_monoid)-- , ("mconcat 1", mytest prop_concat1LL_monoid)- , ("mconcat 2", mytest prop_concat2LL_monoid)- , ("mconcat 3", mytest prop_concatLL_monoid)-- , ("lines", mytest prop_linesBB)- , ("unlines", mytest prop_unlinesBB)- , ("unlines", mytest prop_unlinesLC)- , ("words", mytest prop_wordsBB)- , ("words", mytest prop_wordsLC)- , ("unwords", mytest prop_unwordsBB)- , ("group", mytest prop_groupBB)- , ("groupBy", mytest prop_groupByBB)- , ("groupBy", mytest prop_groupByCC)- , ("groupBy 1", mytest prop_groupBy1BB)- , ("groupBy 1", mytest prop_groupBy1CC)- , ("join", mytest prop_joinBB)- , ("elemIndex 1", mytest prop_elemIndex1BB)- , ("elemIndex 2", mytest prop_elemIndex2BB)- , ("findIndex", mytest prop_findIndexBB)- , ("findIndicies", mytest prop_findIndiciesBB)- , ("elemIndices", mytest prop_elemIndicesBB)- , ("find", mytest prop_findBB)- , ("find/findIndex", mytest prop_find_findIndexBB)- , ("sort 1", mytest prop_sort1BB)- , ("sort 2", mytest prop_sort2BB)- , ("sort 3", mytest prop_sort3BB)- , ("sort 4", mytest prop_sort4BB)- , ("sort 5", mytest prop_sort5BB)- , ("intersperse", mytest prop_intersperseBB)- , ("maximum", mytest prop_maximumBB)- , ("minimum", mytest prop_minimumBB)--- , ("breakChar", mytest prop_breakCharBB)--- , ("spanChar 1", mytest prop_spanCharBB)--- , ("spanChar 2", mytest prop_spanChar_1BB)--- , ("breakSpace", mytest prop_breakSpaceBB)--- , ("dropSpace", mytest prop_dropSpaceBB)- , ("spanEnd", mytest prop_spanEndBB)- , ("breakEnd", mytest prop_breakEndBB)- , ("breakEnd", mytest prop_breakEndCC)- , ("elemIndexEnd 1",mytest prop_elemIndexEnd1BB)- , ("elemIndexEnd 1",mytest prop_elemIndexEnd1CC)- , ("elemIndexEnd 2",mytest prop_elemIndexEnd2BB)--- , ("words'", mytest prop_wordsBB')--- , ("lines'", mytest prop_linesBB')--- , ("dropSpaceEnd", mytest prop_dropSpaceEndBB)- , ("unfoldr", mytest prop_unfoldrBB)- , ("prefix", mytest prop_prefixBB)- , ("suffix", mytest prop_suffixBB)- , ("suffix", mytest prop_suffixLL)- , ("copy", mytest prop_copyBB)- , ("copy", mytest prop_copyLL)- , ("inits", mytest prop_initsBB)- , ("tails", mytest prop_tailsBB)- , ("findSubstrings ",mytest prop_findSubstringsBB)- , ("findSubstring ",mytest prop_findSubstringBB)- , ("breakSubstring 1",mytest prop_breakSubstringBB)- , ("breakSubstring 2",mytest prop_breakSubstring_findSubstring)- , ("breakSubstring 3",mytest prop_breakSubstring_isInfixOf)-- , ("replicate1", mytest prop_replicate1BB)- , ("replicate2", mytest prop_replicate2BB)- , ("replicate3", mytest prop_replicate3BB)- , ("readInt", mytest prop_readintBB)- , ("readInt 2", mytest prop_readint2BB)- , ("readInteger", mytest prop_readintegerBB)- , ("readInteger 2", mytest prop_readinteger2BB)- , ("read", mytest prop_readLL)- , ("read", mytest prop_readBB)- , ("Lazy.readInt", mytest prop_readintLL)- , ("Lazy.readInt", mytest prop_readintLL)- , ("Lazy.readInteger", mytest prop_readintegerLL)- , ("mconcat 1", mytest prop_append1LL_monoid)- , ("mconcat 2", mytest prop_append2LL_monoid)- , ("mconcat 3", mytest prop_append3LL_monoid)--- , ("filterChar1", mytest prop_filterChar1BB)--- , ("filterChar2", mytest prop_filterChar2BB)--- , ("filterChar3", mytest prop_filterChar3BB)--- , ("filterNotChar1", mytest prop_filterNotChar1BB)--- , ("filterNotChar2", mytest prop_filterNotChar2BB)- , ("tail", mytest prop_tailSBB)- , ("index", mytest prop_indexBB)- , ("unsafeIndex", mytest prop_unsafeIndexBB)--- , ("map'", mytest prop_mapBB')- , ("filter", mytest prop_filterBB)- , ("elem", mytest prop_elemSBB)- , ("take", mytest prop_takeSBB)- , ("drop", mytest prop_dropSBB)- , ("splitAt", mytest prop_splitAtSBB)- , ("foldl", mytest prop_foldlBB)- , ("foldr", mytest prop_foldrBB)- , ("takeWhile ", mytest prop_takeWhileSBB)- , ("dropWhile ", mytest prop_dropWhileSBB)- , ("span ", mytest prop_spanSBB)- , ("break ", mytest prop_breakSBB)- , ("breakspan", mytest prop_breakspan_1BB)- , ("lines ", mytest prop_linesSBB)- , ("unlines ", mytest prop_unlinesSBB)- , ("words ", mytest prop_wordsSBB)- , ("unwords ", mytest prop_unwordsSBB)- , ("unwords ", mytest prop_unwordsSLC)--- , ("wordstokens", mytest prop_wordstokensBB)- , ("splitWith", mytest prop_splitWithBB)- , ("joinsplit", mytest prop_joinsplitBB)- , ("intercalate", mytest prop_intercalatePL)--- , ("lineIndices", mytest prop_lineIndices1BB)- , ("count", mytest prop_countBB)--- , ("linessplit", mytest prop_linessplit2BB)- , ("splitsplitWith", mytest prop_splitsplitWithBB)--- , ("joinjoinpath", mytest prop_joinjoinpathBB)- , ("zip", mytest prop_zipBB)- , ("zip", mytest prop_zipLC)- , ("zip1", mytest prop_zip1BB)- , ("zipWith", mytest prop_zipWithBB)- , ("zipWith", mytest prop_zipWithCC)- , ("zipWith", mytest prop_zipWithLC)--- , ("zipWith'", mytest prop_zipWith'BB)- , ("unzip", mytest prop_unzipBB)- , ("concatMap", mytest prop_concatMapBB)--- , ("join/joinByte", mytest prop_join_spec)--- , ("span/spanByte", mytest prop_span_spec)--- , ("break/breakByte",mytest prop_break_spec)- ]----------------------------------------------------------------------------- Fusion rules--{--fusion_tests =--- v1 fusion- [ ("lazy loop/loop fusion", mytest prop_lazylooploop)- , ("loop/loop fusion", mytest prop_looploop)---- v2 fusion- ,("loop/loop wrapper elim", mytest prop_loop_loop_wrapper_elimination)- ,("sequence association", mytest prop_sequenceloops_assoc)-- ,("up/up loop fusion", mytest prop_up_up_loop_fusion)- ,("down/down loop fusion", mytest prop_down_down_loop_fusion)- ,("noAcc/noAcc loop fusion", mytest prop_noAcc_noAcc_loop_fusion)- ,("noAcc/up loop fusion", mytest prop_noAcc_up_loop_fusion)- ,("up/noAcc loop fusion", mytest prop_up_noAcc_loop_fusion)- ,("noAcc/down loop fusion", mytest prop_noAcc_down_loop_fusion)- ,("down/noAcc loop fusion", mytest prop_down_noAcc_loop_fusion)- ,("map/map loop fusion", mytest prop_map_map_loop_fusion)- ,("filter/filter loop fusion", mytest prop_filter_filter_loop_fusion)- ,("map/filter loop fusion", mytest prop_map_filter_loop_fusion)- ,("filter/map loop fusion", mytest prop_filter_map_loop_fusion)- ,("map/noAcc loop fusion", mytest prop_map_noAcc_loop_fusion)- ,("noAcc/map loop fusion", mytest prop_noAcc_map_loop_fusion)- ,("map/up loop fusion", mytest prop_map_up_loop_fusion)- ,("up/map loop fusion", mytest prop_up_map_loop_fusion)- ,("map/down loop fusion", mytest prop_map_down_fusion)- ,("down/map loop fusion", mytest prop_down_map_loop_fusion)- ,("filter/noAcc loop fusion", mytest prop_filter_noAcc_loop_fusion)- ,("noAcc/filter loop fusion", mytest prop_noAcc_filter_loop_fusion)- ,("filter/up loop fusion", mytest prop_filter_up_loop_fusion)- ,("up/filter loop fusion", mytest prop_up_filter_loop_fusion)- ,("filter/down loop fusion", mytest prop_filter_down_fusion)- ,("down/filter loop fusion", mytest prop_down_filter_loop_fusion)--{-- ,("length/loop fusion", mytest prop_length_loop_fusion_1)- ,("length/loop fusion", mytest prop_length_loop_fusion_2)- ,("length/loop fusion", mytest prop_length_loop_fusion_3)- ,("length/loop fusion", mytest prop_length_loop_fusion_4)--}---- ,("zipwith/spec", mytest prop_zipwith_spec)- ]---}------------------------------------------------------------------------------ Extra lazy properties--ll_tests =- [("eq 1", mytest prop_eq1)- ,("eq 2", mytest prop_eq2)- ,("eq 3", mytest prop_eq3)- ,("eq refl", mytest prop_eq_refl)- ,("eq symm", mytest prop_eq_symm)- ,("compare 1", mytest prop_compare1)- ,("compare 2", mytest prop_compare2)- ,("compare 3", mytest prop_compare3)- ,("compare 4", mytest prop_compare4)- ,("compare 5", mytest prop_compare5)- ,("compare 6", mytest prop_compare6)- ,("compare 7", mytest prop_compare7)- ,("compare 8", mytest prop_compare8)- ,("empty 1", mytest prop_empty1)- ,("empty 2", mytest prop_empty2)- ,("pack/unpack", mytest prop_packunpack)- ,("unpack/pack", mytest prop_unpackpack)- ,("null", mytest prop_null)- ,("length 1", mytest prop_length1)- ,("length 2", mytest prop_length2)- ,("cons 1" , mytest prop_cons1)- ,("cons 2" , mytest prop_cons2)- ,("cons 3" , mytest prop_cons3)- ,("cons 4" , mytest prop_cons4)- ,("snoc" , mytest prop_snoc1)- ,("head/pack", mytest prop_head)- ,("head/unpack", mytest prop_head1)- ,("tail/pack", mytest prop_tail)- ,("tail/unpack", mytest prop_tail1)- ,("last", mytest prop_last)- ,("init", mytest prop_init)- ,("append 1", mytest prop_append1)- ,("append 2", mytest prop_append2)- ,("append 3", mytest prop_append3)- ,("map 1", mytest prop_map1)- ,("map 2", mytest prop_map2)- ,("map 3", mytest prop_map3)- ,("filter 1", mytest prop_filter1)- ,("filter 2", mytest prop_filter2)- ,("reverse", mytest prop_reverse)- ,("reverse1", mytest prop_reverse1)- ,("reverse2", mytest prop_reverse2)- ,("transpose", mytest prop_transpose)- ,("foldl", mytest prop_foldl)- ,("foldl/reverse", mytest prop_foldl_1)- ,("foldr", mytest prop_foldr)- ,("foldr/id", mytest prop_foldr_1)- ,("foldl1/foldl", mytest prop_foldl1_1)- ,("foldl1/head", mytest prop_foldl1_2)- ,("foldl1/tail", mytest prop_foldl1_3)- ,("foldr1/foldr", mytest prop_foldr1_1)- ,("foldr1/last", mytest prop_foldr1_2)- ,("foldr1/head", mytest prop_foldr1_3)- ,("concat 1", mytest prop_concat1)- ,("concat 2", mytest prop_concat2)- ,("concat/pack", mytest prop_concat3)- ,("any", mytest prop_any)- ,("all", mytest prop_all)- ,("maximum", mytest prop_maximum)- ,("minimum", mytest prop_minimum)- ,("replicate 1", mytest prop_replicate1)- ,("replicate 2", mytest prop_replicate2)- ,("take", mytest prop_take1)- ,("drop", mytest prop_drop1)- ,("splitAt", mytest prop_drop1)- ,("takeWhile", mytest prop_takeWhile)- ,("dropWhile", mytest prop_dropWhile)- ,("break", mytest prop_break)- ,("span", mytest prop_span)- ,("splitAt", mytest prop_splitAt)- ,("break/span", mytest prop_breakspan)--- ,("break/breakByte", mytest prop_breakByte)--- ,("span/spanByte", mytest prop_spanByte)- ,("split", mytest prop_split)- ,("splitWith", mytest prop_splitWith)- ,("splitWith", mytest prop_splitWith_D)- ,("splitWith", mytest prop_splitWith_C)- ,("join.split/id", mytest prop_joinsplit)--- ,("join/joinByte", mytest prop_joinjoinByte)- ,("group", mytest prop_group)- ,("groupBy", mytest prop_groupBy)- ,("groupBy", mytest prop_groupBy_LC)- ,("index", mytest prop_index)- ,("index", mytest prop_index_D)- ,("index", mytest prop_index_C)- ,("elemIndex", mytest prop_elemIndex)- ,("elemIndices", mytest prop_elemIndices)- ,("count/elemIndices", mytest prop_count)- ,("findIndex", mytest prop_findIndex)- ,("findIndices", mytest prop_findIndicies)- ,("find", mytest prop_find)- ,("find/findIndex", mytest prop_find_findIndex)- ,("elem", mytest prop_elem)- ,("notElem", mytest prop_notElem)- ,("elem/notElem", mytest prop_elem_notelem)--- ,("filterByte 1", mytest prop_filterByte)--- ,("filterByte 2", mytest prop_filterByte2)--- ,("filterNotByte 1", mytest prop_filterNotByte)--- ,("filterNotByte 2", mytest prop_filterNotByte2)- ,("isPrefixOf", mytest prop_isPrefixOf)- ,("concatMap", mytest prop_concatMap)- ,("isSpace", mytest 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
@@ -0,0 +1,142 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}++module QuickCheckUtils+ ( Char8(..)+ , String8(..)+ , CByteString(..)+ , Sqrt(..)+ , int64OK+ , tooStrictErr+ ) where++import Test.Tasty.QuickCheck+import Text.Show.Functions++import Control.Monad ( liftM2 )+import Data.Char+import Data.Word+import Data.Int+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.Char8 as PC+import qualified Data.ByteString.Lazy.Char8 as LC++------------------------------------------------------------------------++sizedByteString n = do m <- choose(0, n)+ fmap P.pack $ vectorOf m arbitrary++instance Arbitrary P.ByteString where+ arbitrary = do+ 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+ where+ fromCChar :: NonZero CChar -> Word8+ fromCChar = fromIntegral . getNonZero++-- | 'Char', but only representing 8-bit characters.+--+newtype Char8 = Char8 Char+ deriving (Eq, Ord, Show)++instance Arbitrary Char8 where+ arbitrary = fmap (Char8 . toChar) arbitrary+ where+ toChar :: Word8 -> Char+ toChar = toEnum . fromIntegral+ shrink (Char8 c) = fmap Char8 (shrink c)++instance CoArbitrary Char8 where+ coarbitrary (Char8 c) = coarbitrary c++-- | 'Char', but only representing 8-bit characters.+--+newtype String8 = String8 String+ deriving (Eq, Ord, Show)++instance Arbitrary String8 where+ arbitrary = fmap (String8 . map toChar) arbitrary+ where+ toChar :: Word8 -> Char+ toChar = toEnum . fromIntegral+ shrink (String8 xs) = fmap String8 (shrink xs)++-- | 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)++instance Arbitrary a => Arbitrary (Sqrt a) where+ arbitrary = Sqrt <$> sized+ (\n -> resize (round @Double $ sqrt $ fromIntegral @Int n) arbitrary)+ shrink = map Sqrt . shrink . unSqrt+++sizedShortByteString :: Int -> Gen SB.ShortByteString+sizedShortByteString n = do m <- choose(0, n)+ fmap SB.pack $ vectorOf m arbitrary++instance Arbitrary SB.ShortByteString where+ arbitrary = sized sizedShortByteString+ shrink = map SB.pack . shrink . SB.unpack++instance CoArbitrary SB.ShortByteString where+ coarbitrary s = coarbitrary (SB.unpack s)++-- | 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)"++-- | 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++tooStrictErr :: forall a. HasCallStack => a+tooStrictErr = withFrozenCallStack $+ error "A lazy sub-expression was unexpectedly evaluated"
+ 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+ ]