diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,241 @@ +[0.12.2.0] — December 2024 + +* Bug fixes: + * [`Builder`: avoid unsound buffer reuse, introduced in `bytestring-0.11.5.0`](https://github.com/haskell/bytestring/pull/691) + * [Fix several bugs around the `byteString` family of `Builders`](https://github.com/haskell/bytestring/pull/671) + * [Make `Data.ByteString.Lazy.zipWith` properly lazy](https://github.com/haskell/bytestring/pull/668) +* API additions: + * [Add `instance IsList Builder`](https://github.com/haskell/bytestring/pull/672) + * [Add `instance NFData BufferRange` and `instance NFData Buffer`](https://github.com/haskell/bytestring/pull/680) + * [Export `toLazyByteString` from `Data.ByteString.Builder.Internal`](https://github.com/haskell/bytestring/pull/672) +* Performance improvements: + * [Remove another dead branch from `toStrict`](https://github.com/haskell/bytestring/pull/663) +* Miscellaneous: + * [Remove support for GHC < 8.4](https://github.com/haskell/bytestring/pull/682) + * Various documentation improvements ([1](https://github.com/haskell/bytestring/pull/683), [2](https://github.com/haskell/bytestring/pull/692)) + + +[0.12.2.0]: https://github.com/haskell/bytestring/compare/0.12.1.0...0.12.2.0 + +[0.12.1.0] — February 2024 + +* [Provisional support has been added for using `bytestring` with GHC's JavaScript back-end.](https://github.com/haskell/bytestring/pull/631) + * This support is relatively un-tested and un-optimised. There may be bugs! Please report any you discover to [`bytestring`'s issue tracker](https://github.com/haskell/bytestring/issues). + * The JavaScript back-end's limited support for the Haskell-C foreign function interface would previously result in many operations failing with errors like `ReferenceError: h$fps_count is not defined`. + * The new `pure-haskell` package flag allows the new fallback Haskell implementations (used to support the JavaScript backend) to be used on most other platforms as well. +* Bug fixes: + * [`stimes 0 sbs :: ShortByteString` now returns the empty `ShortByteString` instead of throwing an exception](https://github.com/haskell/bytestring/pull/611) + * [`stimes 0 b :: Builder` now returns the empty `Builder` instead of throwing an exception](https://github.com/haskell/bytestring/pull/611) + * [Several alignment-related bug fixes](https://github.com/haskell/bytestring/pull/587) + * [Fix a bug in `isValidUtf8`](https://github.com/haskell/bytestring/pull/621) + * [`sconcat @ShortByteString` is no longer terribly inefficient](https://github.com/haskell/bytestring/pull/650) + * [Fix the type on the foreign import used for `Data.ByteString.Short.elemIndex`](https://github.com/haskell/bytestring/pull/661) + * [Ensure that the result of `fromShort` is protected by `mkDeferredByteString`](https://github.com/haskell/bytestring/pull/662) +* Behavior changes: + * [The `Data.Data.Data` instances for `StrictByteString` and `LazyByteString` have been changed:](https://github.com/haskell/bytestring/pull/614) + * `toConstr` now returns the a `pack` pseudo-constructor instead of throwing an exception. + * Due to this pseudo-constructor, `gunfold` can now be meaningfully used at these types. (Previously, it would always raise an exception.) + * These changes allow `syb:Data.Generics.Text.gshow` to be meaningfully used at types containing `ByteString`s. + * [A derived `instance Generic ShortByteString` has been added.](https://github.com/haskell/bytestring/pull/662) + * [`sconcat @Builder` is now lazy in the tail of its input](https://github.com/haskell/bytestring/pull/650) +* Deprecations: + * [`Data.ByteString.Builder.Prim.Internal.storableToF`](https://github.com/haskell/bytestring/pull/649) +* Performance improvements: + * Various raw-binary `Builder` primitives like `intHost` or `word32BE` are much less inefficient on architectures not known to support unaligned writes. ([1](https://github.com/haskell/bytestring/pull/587), [2](https://github.com/haskell/bytestring/pull/645)) + * [Hexadecimal encoding suffers one indirection fewer](https://github.com/haskell/bytestring/pull/624) + * [`Data.ByteString.Lazy.takeEnd` is somewhat faster](https://github.com/haskell/bytestring/pull/629) + * [`Data.ByteString.Lazy.dropEnd` is much faster](https://github.com/haskell/bytestring/pull/629) +* Miscellaneous: + * Various documentation improvements ([1](https://github.com/haskell/bytestring/pull/628), [2](https://github.com/haskell/bytestring/pull/609), [3](https://github.com/haskell/bytestring/pull/612), [4](https://github.com/haskell/bytestring/pull/623), [5](https://github.com/haskell/bytestring/pull/654)) + * [Eta-expand `Data.ByteString.Builder.Internal.empty`](https://github.com/haskell/bytestring/pull/616) + * This can variously help or hurt performance; it undoes the performance changes caused by [CLC proposal 132](https://github.com/haskell/core-libraries-committee/issues/132) with ghc-9.8 and restores the baseline performance seen with older GHCs. + + +[0.12.1.0]: https://github.com/haskell/bytestring/compare/0.12.0.2...0.12.1.0 + +[0.12.0.2] — August 2023 + +* Bug fixes: + * [Fix `clockid_t`-related build failures on some platforms](https://github.com/haskell/bytestring/pull/607) + +[0.12.0.2]: https://github.com/haskell/bytestring/compare/0.12.0.1...0.12.0.2 + +[0.12.0.1] — August 2023 + +* Bug fixes: + * [Work around a GHC runtime linker issue on i386/PowerPC](https://github.com/haskell/bytestring/pull/604) + +[0.12.0.1]: https://github.com/haskell/bytestring/compare/0.12.0.0...0.12.0.1 + +[0.12.0.0] — July 2023 + +* __Breaking Changes__: + * [`readInt` returns `Nothing`, if the sequence of digits cannot be represented by an `Int`, instead of overflowing silently](https://github.com/haskell/bytestring/pull/309) + * [Remove `zipWith` rewrite rule](https://github.com/haskell/bytestring/pull/387) + * [`ShortByteString` is now a wrapper around `Data.Array.Byte.ByteArray` instead of `ByteArray#` directly](https://github.com/haskell/bytestring/pull/410) + * As a compatibility measure, `SBS` remains available as a pattern synonym. + * The compatibility package `data-array-byte` is used when `base` does not provide `Data.Array.Byte`. + * [`fromListN` from `instance IsList ShortByteString` now throws an exception if the first argument does not match the length of the second](https://github.com/haskell/bytestring/pull/410) + * Previously, it would ignore the first argument entirely. +* Bug fixes: + * Size-related calculations are more resistant to `Int` overflow in the following places: + * [`Data.ByteString.intercalate`](https://github.com/haskell/bytestring/pull/468) + * [`stimes @StrictByteString`](https://github.com/haskell/bytestring/pull/443) + * [`Data.ByteString.Short.concat`](https://github.com/haskell/bytestring/pull/443) + * [`Data.ByteString.Short.append`](https://github.com/haskell/bytestring/pull/443) + * [`Data.ByteString.Short.snoc`](https://github.com/haskell/bytestring/pull/599) + * [`Data.ByteString.Short.cons`](https://github.com/haskell/bytestring/pull/599) +* API additions: + * [New sized and/or unsigned variants of `readInt` and `readInteger`](https://github.com/haskell/bytestring/pull/438) + * [`Data.ByteString.Internal` now provides `SizeOverflowException`, `overflowError`, and `checkedMultiply`](https://github.com/haskell/bytestring/pull/443) +* Deprecations: + * `Data.ByteString.getLine`: prefer `Data.ByteString.Char8.getLine` + * `Data.ByteString.hGetLine`: prefer `Data.ByteString.Char8.hGetLine` + + +[0.12.0.0]: https://github.com/haskell/bytestring/compare/0.11.5.0...0.12.0.0 + +[0.11.5.3] — October 2023 + +* Bug fixes: + * [Fix a bug in `isValidUtf8`](https://github.com/haskell/bytestring/pull/621) + +[0.11.5.3]: https://github.com/haskell/bytestring/compare/0.11.5.2...0.11.5.3 + +[0.11.5.2] — August 2023 + +* Bug fixes: + * [Fix `clockid_t`-related build failures on some platforms](https://github.com/haskell/bytestring/pull/607) + +[0.11.5.2]: https://github.com/haskell/bytestring/compare/0.11.5.1...0.11.5.2 + +[0.11.5.1] — August 2023 + +* Bug fixes: + * [Work around a GHC runtime linker issue on i386/PowerPC](https://github.com/haskell/bytestring/pull/604) + +[0.11.5.1]: https://github.com/haskell/bytestring/compare/0.11.5.0...0.11.5.1 + +[0.11.5.0] — July 2023 + +* Bug fixes: + * [Fix multiple bugs with ASCII blocks in the SIMD implementations for `isValidUtf8`](https://github.com/haskell/bytestring/pull/582) + * [Prevent unsound optimizations with the `Data.ByteString.Internal.create*` family of functions](https://github.com/haskell/bytestring/pull/580) +* API additions: + * [`Data.ByteString.Internal` now provides `mkDeferredByteString` and `deferForeignPtrAvailability`](https://github.com/haskell/bytestring/pull/580) +* Deprecations: + * `Data.ByteString.Internal.memcpy`: prefer `Foreign.Marshal.Utils.copyBytes` + * `Data.ByteString.Internal.memset`: prefer `Foreign.Marshal.Utils.fillBytes` +* Performance improvements: + * [Many functions returning `StrictByteString` can now return their results unboxed](https://github.com/haskell/bytestring/pull/580) + * [Dead branches removed from `Lazy.toStrict`](https://github.com/haskell/bytestring/pull/590) + * [`Builder.toLazyByteString` re-uses under-filled buffers after copying their contents](https://github.com/haskell/bytestring/pull/581) +* Miscellaneous: + * [Minor benchmarking improvements](https://github.com/haskell/bytestring/pull/577) + + +[0.11.5.0]: https://github.com/haskell/bytestring/compare/0.11.4.0...0.11.5.0 + +[0.11.4.0] — January 2023 + +* Bug fixes: + * [Prevent commoning-up of `ShortByteString` literals produced by `TemplateHaskell`](https://github.com/haskell/bytestring/pull/542) + * [Make `Builder` literals demand a sane amount of memory at chunk boundaries](https://github.com/haskell/bytestring/pull/538) +* API additions and behavior changes: + * [Export `unsafeIndex` for `ShortByteString` which had been accidentally removed in v0.11.3.0](https://github.com/haskell/bytestring/pull/532) + * [Make `Data.ByteString.Lazy.Char8.lines` less strict](https://github.com/haskell/bytestring/pull/562) + * [Add `NonEmpty` variants of `inits` and `tails`](https://github.com/haskell/bytestring/pull/557) +* Performance improvements: + * [Speed up `unpack` and folds for `ShortByteString`](https://github.com/haskell/bytestring/pull/526) + * [Speed up `Builder`s for non-host endianness](https://github.com/haskell/bytestring/pull/531) + * [Work around upstream `keepAlive#` performance regressions](https://github.com/haskell/bytestring/pull/536) + * [Improve performance of `uncons` for `LazyByteString`](https://github.com/haskell/bytestring/pull/559) + * [Simplify `useAsCString`](https://github.com/haskell/bytestring/pull/516) + * [Remove redundant comparisons in `Data.ByteString.Short.splitAt`](https://github.com/haskell/bytestring/pull/528) +* Miscellaneous: + * [Document possible interleaving of `hPutStrLn` and friends](https://github.com/haskell/bytestring/pull/518) + * [Documentation tweaks](https://github.com/haskell/bytestring/pull/523) + * [Add lower bound for `tasty-quickcheck`](https://github.com/haskell/bytestring/pull/520) + + +[0.11.4.0]: https://github.com/haskell/bytestring/compare/0.11.3.1...0.11.4.0 + +[0.11.3.1] — May 2022 + +* [Windows: Do not link against `gcc_s`](https://github.com/haskell/bytestring/pull/500) +* [Windows: Do not link against `gcc` when GHC >= 9.4](https://github.com/haskell/bytestring/pull/512) +* [Refine CPP for obsolete versions of `gcc`](https://github.com/haskell/bytestring/pull/505) + +[0.11.3.1]: https://github.com/haskell/bytestring/compare/0.11.3.0...0.11.3.1 + +[0.11.3.0] — February 2022 + +Erratum: `unsafeIndex` was accidentally removed from the export list of `Data.ByteString.Short.Internal` in this release. This was corrected in 0.11.4.0. + +* [Enhance `ShortByteString` API](https://github.com/haskell/bytestring/pull/471) + - Add `all`, `any`, `append`, `break`, `breakEnd`, `breakSubstring`, `concat`, `cons`, `count`, `drop`, `dropEnd`, `dropWhile`, `dropWhileEnd`, `elem`, `elemIndex`, `elemIndices`, `filter`, `find`, `findIndex`, `findIndices`, `foldl'`, `foldl`, `foldl1'`, `foldl1`, `foldr'`, `foldr`, `foldr1'`, `foldr1`, `head`, `init`, `intercalate`, `isInfixOf`, `isPrefixOf`, `isSuffixOf`, `last`, `map`, `partition`, `replicate`, `reverse`, `singleton`, `snoc`, `span`, `spanEnd`, `split`, `splitAt`, `splitWith`, `stripPrefix`, `stripSuffix`, `tail`, `take`, `takeEnd`, `takeWhile`, `takeWhileEnd`, `uncons`, `unfoldr`, `unfoldrN`, `unsnoc` to `Data.ByteString.Short`. +* [Add `Data.ByteString.Short.isValidUtf8`](https://github.com/haskell/bytestring/pull/450) +* [Use safe `isValidUtf8` for large inputs](https://github.com/haskell/bytestring/pull/470) +* [Make `unlines` lazier](https://github.com/haskell/bytestring/pull/477) +* [Improve performance of `unlines`](https://github.com/haskell/bytestring/pull/479) +* [Make `singleton` return a slice of a static buffer](https://github.com/haskell/bytestring/pull/480) +* [Improve performance of `intercalate`](https://github.com/haskell/bytestring/pull/459) + +[0.11.3.0]: https://github.com/haskell/bytestring/compare/0.11.2.0...0.11.3.0 + +[0.11.2.0] — December 2021 + +* [Add `Data.ByteString.isValidUtf8`](https://github.com/haskell/bytestring/pull/423) +* [Speed up `floatDec` and `doubleDec` using the Ryu algorithm](https://github.com/haskell/bytestring/pull/365) + - `Data.ByteString.Builder.RealFloat` offers additional custom formatters + for floating point numbers. +* [Add `StrictByteString` and `LazyByteString` type aliases](https://github.com/haskell/bytestring/pull/378) +* [Add `foldr'`, `foldr1'`, `scanl1`, `scanr`, `scanr1` to `Data.ByteString.Lazy{,.Char8}`](https://github.com/haskell/bytestring/pull/364) +* [Add `takeEnd`, `dropEnd`, `takeWhileEnd`, `dropWhileEnd`, `spanEnd`, `breakEnd` to `Data.ByteString.Lazy{,.Char8}`](https://github.com/haskell/bytestring/pull/395) +* [Add `Data.ByteString.Builder.writeFile` to write `Builder` to file directly](https://github.com/haskell/bytestring/pull/408) +* [Add `Data.ByteString.{from,to}FilePath` for encoding-aware conversions](https://github.com/haskell/bytestring/pull/403) +* [Add `Lift` instances for all flavors of `ByteString`](https://github.com/haskell/bytestring/pull/392) +* [Add `HasCallStack` for partial functions](https://github.com/haskell/bytestring/pull/440) +* [Define `foldl`, `foldl'`, `foldr`, `foldr'`, `mapAccumL`, `mapAccumR`, `scanl`, `scanr` and `filter` with one argument less to allow more inlining](https://github.com/haskell/bytestring/pull/345) +* [Speed up internal loop in `unfoldrN`](https://github.com/haskell/bytestring/pull/356) +* [Speed up `count` with SSE and AVX instructions](https://github.com/haskell/bytestring/pull/202) +* [Improve performance of certain `Builder`s by using a static table for Base16](https://github.com/haskell/bytestring/pull/418) +* [Use `unsafeWithForeignPtr` whenever possible](https://github.com/haskell/bytestring/pull/401) +* [Remove `integer-simple` flag](https://github.com/haskell/bytestring/pull/371) +* [Remove misleading mentions of fusion](https://github.com/haskell/bytestring/pull/412) + +[0.11.2.0]: https://github.com/haskell/bytestring/compare/0.11.1.0...0.11.2.0 + [0.11.1.0] — February 2021 * [Add `Data.ByteString.Char8.findIndexEnd` and `Data.ByteString.Lazy.Char8.{elemIndexEnd,findIndexEnd,unzip}`](https://github.com/haskell/bytestring/pull/342) @@ -55,7 +293,7 @@ * [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 `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) diff --git a/Data/ByteString.hs b/Data/ByteString.hs --- a/Data/ByteString.hs +++ b/Data/ByteString.hs @@ -1,2050 +1,2079 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_HADDOCK prune #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - --- | --- Module : Data.ByteString --- Copyright : (c) The University of Glasgow 2001, --- (c) David Roundy 2003-2005, --- (c) Simon Marlow 2005, --- (c) Bjorn Bringert 2006, --- (c) Don Stewart 2005-2008, --- (c) Duncan Coutts 2006-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 ( - - -- * 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] - fromStrict, -- :: ByteString -> Lazy.ByteString - toStrict, -- :: Lazy.ByteString -> ByteString - - -- * Basic interface - cons, -- :: Word8 -> ByteString -> ByteString - snoc, -- :: ByteString -> Word8 -> ByteString - append, -- :: ByteString -> ByteString -> ByteString - head, -- :: ByteString -> Word8 - uncons, -- :: ByteString -> Maybe (Word8, ByteString) - unsnoc, -- :: ByteString -> Maybe (ByteString, Word8) - 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 - takeEnd, -- :: Int -> ByteString -> ByteString - drop, -- :: Int -> ByteString -> ByteString - dropEnd, -- :: Int -> ByteString -> ByteString - splitAt, -- :: Int -> ByteString -> (ByteString, ByteString) - takeWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString - takeWhileEnd, -- :: (Word8 -> Bool) -> ByteString -> ByteString - dropWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString - dropWhileEnd, -- :: (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] - stripPrefix, -- :: ByteString -> ByteString -> Maybe ByteString - stripSuffix, -- :: ByteString -> ByteString -> Maybe 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) - - -- * 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 - indexMaybe, -- :: ByteString -> Int -> Maybe Word8 - (!?), -- :: ByteString -> Int -> Maybe 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] - findIndexEnd, -- :: (Word8 -> Bool) -> ByteString -> Maybe Int - count, -- :: Word8 -> ByteString -> Int - - -- * Zipping and unzipping ByteStrings - zip, -- :: ByteString -> ByteString -> [(Word8,Word8)] - zipWith, -- :: (Word8 -> Word8 -> c) -> ByteString -> ByteString -> [c] - packZipWith, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> ByteString - 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 () - 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 () - ) 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 -#if !MIN_VERSION_base(4,6,0) - ,catch -#endif - ) - -#if MIN_VERSION_base(4,7,0) -import Data.Bits (finiteBitSize, shiftL, (.|.), (.&.)) -#else -import Data.Bits (bitSize, shiftL, (.|.), (.&.)) -#endif - -import Data.ByteString.Internal -import Data.ByteString.Lazy.Internal (fromStrict, toStrict) -import Data.ByteString.Unsafe - -import qualified Data.List as List - -import Data.Word (Word8) - -import Control.Exception (IOException, catch, finally, assert, throwIO) -import Control.Monad (when, void) - -import Foreign.C.String (CString, CStringLen) -import Foreign.C.Types (CSize) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, touchForeignPtr) -#if MIN_VERSION_base(4,5,0) -import Foreign.ForeignPtr.Unsafe(unsafeForeignPtrToPtr) -#else -import Foreign.ForeignPtr (unsafeForeignPtrToPtr) -#endif -import Foreign.Marshal.Alloc (allocaBytes) -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,hGetBufNonBlocking - ,hPutBufNonBlocking,withBinaryFile - ,IOMode(..),hGetBufSome) -import System.IO.Error (mkIOError, illegalOperationErrorType) - -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative ((<$>)) -import Data.Monoid (Monoid(..)) -#endif - -import Data.IORef -import GHC.IO.Handle.Internals -import GHC.IO.Handle.Types -import GHC.IO.Buffer -import GHC.IO.BufferedIO as Buffered -import GHC.IO (unsafePerformIO, unsafeDupablePerformIO) -import Data.Char (ord) -import Foreign.Marshal.Utils (copyBytes) - -import GHC.Base (build) -import GHC.Word hiding (Word8) - -#if !(MIN_VERSION_base(4,7,0)) -finiteBitSize = bitSize -#endif - --- ----------------------------------------------------------------------------- --- Introducing and eliminating 'ByteString's - --- | /O(1)/ The empty 'ByteString' -empty :: ByteString -empty = BS nullForeignPtr 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 '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 - #-} - --- --------------------------------------------------------------------- --- 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 l) = unsafeCreate (l+1) $ \p -> unsafeWithForeignPtr x $ \f -> do - poke p c - memcpy (p `plusPtr` 1) f (fromIntegral l) -{-# INLINE cons #-} - --- | /O(n)/ Append a byte to the end of a 'ByteString' -snoc :: ByteString -> Word8 -> ByteString -snoc (BS x l) c = unsafeCreate (l+1) $ \p -> unsafeWithForeignPtr x $ \f -> do - memcpy p f (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 (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. -tail :: 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. -last :: ByteString -> Word8 -last ps@(BS x l) - | null ps = errorEmptyList "last" - | otherwise = accursedUnutterablePerformIO $ - unsafeWithForeignPtr x $ \p -> peekByteOff p (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@(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 fp len) = unsafeDupablePerformIO $ unsafeWithForeignPtr fp $ \srcPtr -> - create len $ \dstPtr -> m srcPtr dstPtr - where - m !p1 !p2 = map_ 0 - where - map_ :: Int -> IO () - map_ !n - | n >= len = return () - | otherwise = do - x <- peekByteOff p1 n - pokeByteOff 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) = unsafeCreate l $ \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 = unsafeCreate (2*l-1) $ \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) = go (end `plusPtr` len) - where - 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 -{-# INLINE foldl #-} - --- | 'foldl'' is like 'foldl', but strict in the accumulator. --- -foldl' :: (a -> Word8 -> a) -> a -> ByteString -> a -foldl' f v (BS fp len) = - accursedUnutterablePerformIO $ unsafeWithForeignPtr fp g - where - g ptr = go v ptr - where - end = ptr `plusPtr` len - -- tail recursive; traverses array left to right - go !z !p | p == end = return z - | otherwise = do x <- peek p - go (f z x) (p `plusPtr` 1) -{-# 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) = go ptr - where - 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)) -{-# INLINE foldr #-} - --- | 'foldr'' is like 'foldr', but strict in the accumulator. -foldr' :: (Word8 -> a -> a) -> a -> ByteString -> a -foldr' k v (BS fp len) = - accursedUnutterablePerformIO $ unsafeWithForeignPtr fp g - where - g ptr = go v (end `plusPtr` len) - where - end = ptr `plusPtr` (-1) - -- tail recursive; traverses array right to left - go !z !p | p == end = return z - | otherwise = do x <- peek p - go (k x z) (p `plusPtr` (-1)) -{-# 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 :: (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' :: (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 :: (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' :: (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 $ unsafeWithForeignPtr x g - where - g ptr = go ptr - where - end = ptr `plusPtr` len - go !p | p == end = return False - | otherwise = do c <- peek p - if f c then return True - else go (p `plusPtr` 1) -{-# INLINE [1] any #-} - -#if MIN_VERSION_base(4,9,0) -{-# RULES -"ByteString specialise any (x ==)" forall x. - any (x `eqWord8`) = anyByte x -"ByteString specialise any (== x)" forall x. - any (`eqWord8` x) = anyByte x - #-} -#else -{-# RULES -"ByteString specialise any (x ==)" forall x. - any (x ==) = anyByte x -"ByteString specialise any (== x)" forall x. - any (== x) = anyByte x - #-} -#endif - --- | 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 #-} - --- 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 _ (BS _ 0) = True -all f (BS x len) = accursedUnutterablePerformIO $ unsafeWithForeignPtr x g - where - g ptr = go ptr - where - end = ptr `plusPtr` len - go !p | p == end = return True -- end of list - | otherwise = do c <- peek p - if f c - then go (p `plusPtr` 1) - else return False -{-# INLINE [1] all #-} - -#if MIN_VERSION_base(4,9,0) -{-# 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 - #-} -#else -{-# RULES -"ByteString specialise all (x /=)" forall x. - all (x /=) = not . anyByte x -"ByteString specialise all (/= x)" forall x. - all (/= x) = not . anyByte x - #-} -#endif - ------------------------------------------------------------------------- - --- | /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@(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' --- This function will fuse. --- An exception will be thrown in the case of an empty ByteString. -minimum :: 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 list. -mapAccumL :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) -mapAccumL f acc (BS fp len) = unsafeDupablePerformIO $ unsafeWithForeignPtr fp $ \a -> do - gp <- mallocByteString len - acc' <- unsafeWithForeignPtr gp (go a) - return (acc', BS gp len) - where - go src dst = mapAccumL_ acc 0 - where - mapAccumL_ !s !n - | n >= len = return s - | otherwise = do - x <- peekByteOff src n - let (s', y) = f s x - pokeByteOff dst n y - mapAccumL_ s' (n+1) -{-# 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 fp len) = unsafeDupablePerformIO $ unsafeWithForeignPtr fp $ \a -> do - gp <- mallocByteString len - acc' <- unsafeWithForeignPtr gp (go a) - return (acc', BS gp len) - where - go src dst = mapAccumR_ acc (len-1) - where - mapAccumR_ !s (-1) = return s - mapAccumR_ !s !n = do - x <- peekByteOff src n - let (s', y) = f s x - pokeByteOff dst n y - mapAccumR_ s' (n-1) -{-# 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 --- --- > 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 fp len) = unsafeDupablePerformIO $ unsafeWithForeignPtr fp $ \a -> - create (len+1) $ \q -> do - poke q v - go a (q `plusPtr` 1) - where - go src dst = scanl_ v 0 - where - scanl_ !z !n - | n >= len = return () - | otherwise = do - x <- peekByteOff src n - let z' = f z x - pokeByteOff dst n z' - scanl_ z' (n+1) -{-# 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 = 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 fp len) = unsafeDupablePerformIO $ unsafeWithForeignPtr fp $ \a -> - create (len+1) $ \q -> do - poke (q `plusPtr` len) v - go a q - where - go p q = scanr_ v (len-1) - where - scanr_ !z !n - | n < 0 = return () - | otherwise = do - x <- peekByteOff p n - let z' = f x z - pokeByteOff q n z' - scanr_ z' (n-1) -{-# 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 = unfoldr w (\u -> Just (u,u)) c --- --- This implementation uses @memset(3)@ -replicate :: Int -> Word8 -> ByteString -replicate w c - | w <= 0 = empty - | otherwise = unsafeCreate w $ \ptr -> - void $ memset ptr c (fromIntegral 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 = unsafePerformIO $ createAndTrim' i $ \p -> go p x0 0 - where - go !p !x !n - | n == i = return (0, n, Just x) - | otherwise = case f x of - Nothing -> return (0, n, Nothing) - Just (w,x') -> 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@(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 @[]@ 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 'P.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 #-} - -#if MIN_VERSION_base(4,9,0) -{-# 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 - #-} -#else -{-# RULES -"ByteString specialise takeWhile (x /=)" forall x. - takeWhile (x /=) = fst . breakByte x -"ByteString specialise takeWhile (/= x)" forall x. - takeWhile (/= x) = fst . breakByte x -"ByteString specialise takeWhile (x ==)" forall x. - takeWhile (x ==) = fst . spanByte x -"ByteString specialise takeWhile (== x)" forall x. - takeWhile (== x) = fst . spanByte x - #-} -#endif - --- | 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 'P.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 #-} - -#if MIN_VERSION_base(4,9,0) -{-# 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 - #-} -#else -{-# RULES -"ByteString specialise dropWhile (x /=)" forall x. - dropWhile (x /=) = snd . breakByte x -"ByteString specialise dropWhile (/= x)" forall x. - dropWhile (/= x) = snd . breakByte x -"ByteString specialise dropWhile (x ==)" forall x. - dropWhile (x ==) = snd . spanByte x -"ByteString specialise dropWhile (== x)" forall x. - dropWhile (== x) = snd . spanByte x - #-} -#endif - --- | 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.10.12.0 -dropWhileEnd :: (Word8 -> Bool) -> ByteString -> ByteString -dropWhileEnd f ps = unsafeTake (findFromEndUntil (not . f) ps) ps -{-# INLINE dropWhileEnd #-} - --- | Similar to 'P.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 -#if MIN_VERSION_base(4,9,0) -{-# RULES -"ByteString specialise break (x ==)" forall x. - break (x `eqWord8`) = breakByte x -"ByteString specialise break (== x)" forall x. - break (`eqWord8` x) = breakByte x - #-} -#else -{-# RULES -"ByteString specialise break (x ==)" forall x. - break (x ==) = breakByte x -"ByteString specialise break (== x)" forall x. - break (== x) = breakByte x - #-} -#endif - --- 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 (==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 @('takeWhileEnd' (not . p) &&& 'dropWhileEnd' (not . p))@. --- -breakEnd :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) -breakEnd p ps = splitAt (findFromEndUntil p ps) ps - --- | Similar to 'P.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 --- occurence 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 -#if MIN_VERSION_base(4,9,0) -{-# RULES -"ByteString specialise span (x ==)" forall x. - span (x `eqWord8`) = spanByte x -"ByteString specialise span (== x)" forall x. - span (`eqWord8` x) = spanByte x - #-} -#else -{-# RULES -"ByteString specialise span (x ==)" forall x. - span (x ==) = spanByte x -"ByteString specialise span (== x)" forall x. - span (== x) = spanByte x - #-} -#endif - --- | 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) 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 $ - unsafeWithForeignPtr fp $ \p -> - splitLoop p 0 off' len' fp' - - splitLoop :: Ptr 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 <- peekElemOff 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 = accursedUnutterablePerformIO $ withForeignPtr x $ \p -> - return (q `minusPtr` p) - 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 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 = 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 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@(BS ffp l) g@(BS fgp m) = unsafeCreate len $ \ptr -> - unsafeWithForeignPtr ffp $ \fp -> - unsafeWithForeignPtr fgp $ \gp -> do - memcpy ptr fp (fromIntegral l) - poke (ptr `plusPtr` l) c - memcpy (ptr `plusPtr` (l + 1)) gp (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(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 $ withForeignPtr x g - where - g !ptr = go 0 - where - go !n | n >= l = return Nothing - | otherwise = do w <- peek $ ptr `plusPtr` 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 $ withForeignPtr x g - where - g !ptr = go (l-1) - where - go !n | n < 0 = return Nothing - | otherwise = do w <- peekByteOff 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 #-} - - -#if MIN_VERSION_base(4,9,0) -{-# 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 - #-} -#else -{-# RULES -"ByteString specialise findIndex (x ==)" forall x. findIndex (x==) = elemIndex x -"ByteString specialise findIndex (== x)" forall x. findIndex (==x) = elemIndex x -"ByteString specialise findIndices (x ==)" forall x. findIndices (x==) = elemIndices x -"ByteString specialise findIndices (== x)" forall x. findIndices (==x) = elemIndices x - #-} -#endif - --- --------------------------------------------------------------------- --- 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 x l) - | null ps = ps - | otherwise = unsafePerformIO $ createAndTrim l $ \p -> withForeignPtr x $ \f -> do - t <- go' f p - return $! t `minusPtr` p -- actual length - where - go' pf pt = go pf pt - where - end = pf `plusPtr` l - go !f !t | f == end = return t - | otherwise = do - w <- peek f - if k w - then poke t w >> go (f `plusPtr` 1) (t `plusPtr` 1) - else go (f `plusPtr` 1) t -{-# 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 fp' <- mallocByteString len - withForeignPtr fp' $ \p -> - do let end = p `plusPtr` (len - 1) - mid <- sep 0 p end - rev mid end - let i = mid `minusPtr` p - return (BS fp' i, - BS (plusForeignPtr fp' i) (len - i)) - where - len = length s - incr = (`plusPtr` 1) - decr = (`plusPtr` (-1)) - - sep !i !p1 !p2 - | i == len = return p1 - | f w = do poke p1 w - sep (i + 1) (incr p1) p2 - | otherwise = do poke p2 w - sep (i + 1) p1 (decr p2) - where - w = s `unsafeIndex` i - - rev !p1 !p2 - | p1 >= p2 = return () - | otherwise = do a <- peek p1 - b <- peek p2 - poke p1 b - poke 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 -> - withForeignPtr 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 -> - withForeignPtr 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) - --- | 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 occurence 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 fp l) (BS fq m) = unsafeDupablePerformIO $ - withForeignPtr fp $ \a -> - withForeignPtr fq $ \b -> - create len $ go a b - where - go p1 p2 = zipWith_ 0 - where - zipWith_ :: Int -> Ptr Word8 -> IO () - zipWith_ !n !r - | n >= len = return () - | otherwise = do - x <- peekByteOff p1 n - y <- peekByteOff p2 n - pokeByteOff r n (f x y) - zipWith_ (n+1) r - - len = min l m -{-# INLINE packZipWith #-} - -{-# RULES -"ByteString specialise zipWith" forall (f :: Word8 -> Word8 -> Word8) p q . - zipWith f p q = unpack (packZipWith 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 (BS x l) = [BS x 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 (BS x l) = [BS (plusForeignPtr x n) (l-n) | n <- [0..l]] - --- --------------------------------------------------------------------- --- ** 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 = unsafeCreate l $ \ptr -> withForeignPtr input $ \inp -> do - memcpy ptr inp (fromIntegral l) - c_sort ptr (fromIntegral l) - | otherwise = unsafeCreate l $ \p -> allocaArray 256 $ \arr -> do - - _ <- memset (castPtr arr) 0 (256 * fromIntegral (sizeOf (undefined :: CSize))) - unsafeWithForeignPtr input (\x -> countOccurrences arr x l) - - let go 256 !_ = return () - go i !ptr = do n <- peekElemOff arr i - when (n /= 0) $ void $ memset ptr (fromIntegral i) n - 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 () - 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 -> - withForeignPtr fp $ \p -> do - memcpy buf p (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@. --- It must not be stored or used after the subcomputation finishes. -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 = create len $ \p -> - memcpy p (castPtr cstr) (fromIntegral len) -packCStringLen (_, len) = - moduleErrorIO "packCStringLen" ("negative length: " ++ show len) - ------------------------------------------------------------------------- - --- | /O(n)/ Make a copy of the 'ByteString' with its own storage. --- This is mainly useful to allow the rest of the data pointed --- to by the 'ByteString' to be garbage collected, for example --- if a large string has been read in, and only a small part of it --- is needed in the rest of the program. --- -copy :: ByteString -> ByteString -copy (BS x l) = unsafeCreate l $ \p -> unsafeWithForeignPtr x $ \f -> - memcpy p f (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 -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 - -mkPS :: RawBuffer Word8 -> Int -> Int -> IO ByteString -mkPS buf start end = - create len $ \p -> - withRawBuffer buf $ \pbuf -> copyBytes p (pbuf `plusPtr` 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 = 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 -hGetNonBlocking h i - | i > 0 = createAndTrim i $ \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 = createAndTrim i $ \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 :: String -> a -errorEmptyList fun = moduleError fun "empty ByteString" -{-# NOINLINE errorEmptyList #-} - -moduleError :: String -> String -> a -moduleError fun msg = error (moduleErrorMsg fun msg) -{-# NOINLINE moduleError #-} - -moduleErrorIO :: String -> String -> IO a +{-# 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 #-} diff --git a/Data/ByteString/Builder.hs b/Data/ByteString/Builder.hs --- a/Data/ByteString/Builder.hs +++ b/Data/ByteString/Builder.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP, MagicHash #-} -{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-orphans #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif + +{-# 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) @@ -27,10 +27,10 @@ 'Builder's support (a) by providing an /O(1)/ concatentation operation and efficient implementations of basic encodings for 'Char's, 'Int's, and other standard Haskell values. -They support (b) by providing their result as a lazy 'L.ByteString', +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. -Lazy 'L.ByteString's can be efficiently consumed by functions that +'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. @@ -52,18 +52,12 @@ >type Row = [Cell] >type Table = [Row] -We use the following imports and abbreviate 'mappend' to simplify reading. +We use the following imports. @ import qualified "Data.ByteString.Lazy" as L import "Data.ByteString.Builder" -import Data.Monoid -import Data.Foldable ('Data.Foldable.foldMap') import Data.List ('Data.List.intersperse') - -infixr 4 \<\> -(\<\>) :: 'Monoid' m => m -> m -> m -(\<\>) = 'mappend' @ CSV is a character-based representation of tables. For maximal modularity, @@ -72,15 +66,15 @@ due to the intermediate 'String' representation being built and thrown away right afterwards. We get rid of this intermediate 'String' representation by fixing the character encoding to UTF-8 and using 'Builder's to convert -@Table@s directly to UTF-8 encoded CSV tables represented as lazy -'L.ByteString's. +@Table@s directly to UTF-8 encoded CSV tables represented as +'L.LazyByteString's. @ -encodeUtf8CSV :: Table -> L.ByteString +encodeUtf8CSV :: Table -> L.LazyByteString encodeUtf8CSV = 'toLazyByteString' . renderTable renderTable :: Table -> Builder -renderTable rs = 'mconcat' [renderRow r \<\> 'charUtf8' \'\\n\' | r <- rs] +renderTable rs = 'mconcat' [renderRow r '<>' 'charUtf8' \'\\n\' | r <- rs] renderRow :: Row -> Builder renderRow [] = 'mempty' @@ -92,7 +86,7 @@ renderCell (IntC i) = 'intDec' i renderString :: String -> Builder -renderString cs = charUtf8 \'\"\' \<\> foldMap escape cs \<\> charUtf8 \'\"\' +renderString cs = charUtf8 \'\"\' \<\> 'foldMap' escape cs \<\> charUtf8 \'\"\' where escape \'\\\\\' = charUtf8 \'\\\\\' \<\> charUtf8 \'\\\\\' escape \'\\\"\' = charUtf8 \'\\\\\' \<\> charUtf8 \'\\\"\' @@ -121,7 +115,7 @@ @ The expression @encodeUtf8CSV table@ results in the following lazy -'L.ByteString'. +'L.LazyByteString'. >Chunk "\"hello\",\"\\\"1\\\"\",\"\206\187-w\195\182rld\"\n-3,-2,-1,0,1,2,3\n" Empty @@ -144,7 +138,7 @@ > ] On a Core2 Duo 2.20GHz on a 32-bit Linux, - the above code takes 1ms to generate the 22'500 bytes long lazy 'L.ByteString'. + 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. @@ -155,7 +149,7 @@ >renderRow = mconcat . intersperse (charUtf8 ',') . map renderCell Similarly, using /O(n)/ concatentations like '++' or the equivalent 'Data.ByteString.concat' - operations on strict and lazy 'L.ByteString's should be avoided. + operations on strict and 'L.LazyByteString's should be avoided. The following definition of @renderString@ is also about 20% slower. >renderString :: String -> Builder @@ -185,12 +179,13 @@ -- signal to the driver telling it that it is either done, has filled the -- current buffer, or wants to directly insert a reference to a chunk of -- memory. In the last two cases, the 'Builder' also returns a - -- continutation 'Builder' that the driver can call to fill the next + -- 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 @@ -252,28 +247,23 @@ , 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 qualified Data.ByteString.Lazy.Internal as L import Data.ByteString.Builder.ASCII +import Data.ByteString.Builder.RealFloat import Data.String (IsString(..)) -import System.IO (Handle) +import System.IO (Handle, IOMode(..), withBinaryFile) import Foreign import GHC.Base (unpackCString#, unpackCStringUtf8#, unpackFoldrCString#, build) --- | Execute a 'Builder' and return the generated chunks as a lazy 'L.ByteString'. --- The work is performed lazy, i.e., only when a chunk of the lazy 'L.ByteString' --- is forced. -{-# NOINLINE toLazyByteString #-} -- ensure code is shared -toLazyByteString :: Builder -> L.ByteString -toLazyByteString = toLazyByteStringWith - (safeStrategy L.smallChunkSize L.defaultChunkSize) L.Empty - {- Not yet stable enough. See note on 'hPut' in Data.ByteString.Builder.Internal -} @@ -294,6 +284,17 @@ 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 diff --git a/Data/ByteString/Builder/ASCII.hs b/Data/ByteString/Builder/ASCII.hs --- a/Data/ByteString/Builder/ASCII.hs +++ b/Data/ByteString/Builder/ASCII.hs @@ -1,9 +1,5 @@ -{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface, - MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif + -- | Copyright : (c) 2010 - 2011 Simon Meier -- License : BSD3-style (see LICENSE) -- @@ -81,47 +77,12 @@ import Data.ByteString.Lazy as L import Data.ByteString.Builder.Internal (Builder) import qualified Data.ByteString.Builder.Prim as P - -import Foreign - - -#if __GLASGOW_HASKELL__ >= 811 - -import GHC.Num.Integer -#define HAS_INTEGER_CONSTR 1 -#define quotRemInteger integerQuotRem# - -#elif defined(INTEGER_GMP) - -#define HAS_INTEGER_CONSTR 1 -#define IS S# - -# if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid (mappend) -# endif - -# if __GLASGOW_HASKELL__ < 710 -import GHC.Num (quotRemInteger) -# endif - -import GHC.Integer.GMP.Internals -#endif - -#if HAS_INTEGER_CONSTR import qualified Data.ByteString.Builder.Prim.Internal as P -import Foreign.C.Types -import GHC.Types (Int(..)) -#endif - ------------------------------------------------------------------------------- --- Decimal Encoding ------------------------------------------------------------------------------- - +import Data.ByteString.Builder.RealFloat (floatDec, doubleDec) +import Data.ByteString.Internal.Type (c_int_dec_padded9, c_long_long_int_dec_padded18) --- | Encode a 'String' using 'P.char7'. -{-# INLINE string7 #-} -string7 :: String -> Builder -string7 = P.primMapListFixed P.char7 +import Foreign +import Data.List.NonEmpty (NonEmpty(..)) ------------------------------------------------------------------------------ -- Decimal Encoding @@ -191,22 +152,6 @@ wordDec = P.primBounded P.wordDec --- Floating point numbers -------------------------- - --- TODO: Use Bryan O'Sullivan's double-conversion package to speed it up. - --- | /Currently slow./ Decimal encoding of an IEEE 'Float'. -{-# INLINE floatDec #-} -floatDec :: Float -> Builder -floatDec = string7 . show - --- | /Currently slow./ Decimal encoding of an IEEE 'Double'. -{-# INLINE doubleDec #-} -doubleDec :: Double -> Builder -doubleDec = string7 . show - - ------------------------------------------------------------------------------ -- Hexadecimal Encoding ------------------------------------------------------------------------------ @@ -293,14 +238,14 @@ doubleHexFixed :: Double -> Builder doubleHexFixed = P.primFixed P.doubleHexFixed --- | Encode each byte of a 'S.ByteString' using its fixed-width hex encoding. +-- | Encode each byte of a 'S.StrictByteString' using its fixed-width hex encoding. {-# NOINLINE byteStringHex #-} -- share code -byteStringHex :: S.ByteString -> Builder +byteStringHex :: S.StrictByteString -> Builder byteStringHex = P.primMapByteStringFixed P.word8HexFixed --- | Encode each byte of a lazy 'L.ByteString' using its fixed-width hex encoding. +-- | Encode each byte of a 'L.LazyByteString' using its fixed-width hex encoding. {-# NOINLINE lazyByteStringHex #-} -- share code -lazyByteStringHex :: L.ByteString -> Builder +lazyByteStringHex :: L.LazyByteString -> Builder lazyByteStringHex = P.primMapLazyByteStringFixed P.word8HexFixed @@ -308,14 +253,11 @@ -- Fast decimal 'Integer' encoding. ------------------------------------------------------------------------------ -#if HAS_INTEGER_CONSTR -- An optimized version of the integer serialization code -- in blaze-textual (c) 2011 MailRank, Inc. Bryan O'Sullivan -- . It is 2.5x faster on Int-sized integers and 4.5x faster -- on larger integers. -# define PAIR(a,b) (# a,b #) - -- | 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) @@ -327,68 +269,47 @@ -- | Decimal encoding of an 'Integer' using the ASCII digits. integerDec :: Integer -> Builder -integerDec (IS i#) = intDec (I# i#) integerDec i + | i' <- fromInteger i, toInteger i' == i = intDec i' | i < 0 = P.primFixed P.char8 '-' `mappend` go (-i) | otherwise = go i where - errImpossible fun = - error $ "integerDec: " ++ fun ++ ": the impossible happened." - 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 - [] -> errImpossible "integerDec: go" + x:|xs -> intDec x `mappend` P.primMapListBounded intDecPadded xs - splitf :: Integer -> Integer -> [Integer] + splitf :: Integer -> Integer -> NonEmpty Integer splitf pow10 n0 - | pow10 > n0 = [n0] + | pow10 > n0 = n0 :| [] | otherwise = splith (splitf (pow10 * pow10) n0) where - splith [] = errImpossible "splith" - splith (n:ns) = - case n `quotRemInteger` pow10 of - PAIR(q,r) | q > 0 -> q : r : splitb ns - | otherwise -> r : splitb ns + 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 `quotRemInteger` pow10 of - PAIR(q,r) -> q : r : splitb ns + splitb (n:ns) = case n `quotRem` pow10 of + (q,r) -> q : r : splitb ns - putH :: [Integer] -> [Int] - putH [] = errImpossible "putH" - putH (n:ns) = case n `quotRemInteger` maxPow10 of - PAIR(x,y) - | q > 0 -> q : r : putB ns - | otherwise -> r : putB 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 `quotRemInteger` maxPow10 of - PAIR(q,r) -> fromInteger q : fromInteger r : putB ns + putB (n:ns) = case n `quotRem` maxPow10 of + (q,r) -> fromInteger q : fromInteger r : putB ns -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 () - {-# 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) - -#else --- compilers other than GHC - --- | Decimal encoding of an 'Integer' using the ASCII digits. Implemented --- using via the 'Show' instance of 'Integer's. -integerDec :: Integer -> Builder -integerDec = string7 . show -#endif diff --git a/Data/ByteString/Builder/Extra.hs b/Data/ByteString/Builder/Extra.hs --- a/Data/ByteString/Builder/Extra.hs +++ b/Data/ByteString/Builder/Extra.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif + ----------------------------------------------------------------------------- -- | Copyright : (c) 2010 Jasper Van der Jeugt -- (c) 2010-2011 Simon Meier @@ -81,7 +78,7 @@ -- * an IO action for writing the Builder's data into a user-supplied memory -- buffer. -- --- * a pre-existing chunks of data represented by a strict 'S.ByteString' +-- * 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. @@ -110,10 +107,10 @@ -- | 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.ByteString'. It also gives you the following 'BufferWriter' + -- 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.ByteString BufferWriter + | Chunk !S.StrictByteString BufferWriter -- | Turn a 'Builder' into its initial 'BufferWriter' action. -- diff --git a/Data/ByteString/Builder/Internal.hs b/Data/ByteString/Builder/Internal.hs --- a/Data/ByteString/Builder/Internal.hs +++ b/Data/ByteString/Builder/Internal.hs @@ -1,12 +1,9 @@ -{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns, RankNTypes, TupleSections #-} -#if __GLASGOW_HASKELL__ == 700 --- This is needed as a workaround for an old bug in GHC 7.0.1 (Trac #4498) -{-# LANGUAGE MonoPatBinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Unsafe #-} -#endif +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} + {-# OPTIONS_HADDOCK not-home #-} + -- | Copyright : (c) 2010 - 2011 Simon Meier -- License : BSD3-style (see LICENSE) -- @@ -104,6 +101,7 @@ , lazyByteString -- ** Execution + , toLazyByteString , toLazyByteStringWith , AllocationStrategy , safeStrategy @@ -133,17 +131,15 @@ ) where import Control.Arrow (second) +import Control.DeepSeq (NFData(..)) +import GHC.Exts (IsList(..)) -#if !(MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup((<>))) -#endif -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -import Control.Applicative (Applicative(..),(<$>)) -#endif +import Data.Semigroup (Semigroup(..)) +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.ByteString as S -import qualified Data.ByteString.Internal 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 @@ -153,18 +149,9 @@ import System.IO (hFlush, BufferMode(..), Handle) import Data.IORef -#if MIN_VERSION_base(4,4,0) -#if MIN_VERSION_base(4,7,0) import Foreign -#else -import Foreign hiding (unsafeForeignPtrToPtr) -#endif import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import System.IO.Unsafe (unsafeDupablePerformIO) -#else -import Foreign -import GHC.IO (unsafeDupablePerformIO) -#endif ------------------------------------------------------------------------------ -- Buffers @@ -174,11 +161,22 @@ 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 #-} @@ -194,17 +192,17 @@ let pbuf = unsafeForeignPtrToPtr fpbuf return $! Buffer fpbuf (BufferRange pbuf (pbuf `plusPtr` size)) --- | Convert the filled part of a 'Buffer' to a strict 'S.ByteString'. +-- | Convert the filled part of a 'Buffer' to a 'S.StrictByteString'. {-# INLINE byteStringFromBuffer #-} -byteStringFromBuffer :: Buffer -> S.ByteString +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 lazy 'L.ByteString' +-- | Prepend the filled part of a 'Buffer' to a 'L.LazyByteString' -- trimming it if necessary. {-# INLINE trimmedChunkFromBuffer #-} trimmedChunkFromBuffer :: AllocationStrategy -> Buffer - -> L.ByteString -> L.ByteString + -> 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 @@ -225,33 +223,33 @@ data ChunkIOStream a = Finished Buffer a -- ^ The partially filled last buffer together with the result. - | Yield1 S.ByteString (IO (ChunkIOStream a)) - -- ^ Yield a /non-empty/ strict 'S.ByteString'. + | 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.ByteString -> IO (ChunkIOStream a) -> IO (ChunkIOStream a) +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 lazy 'L.ByteString' using +-- | Convert a @'ChunkIOStream' ()@ to a 'L.LazyByteString' using -- 'unsafeDupablePerformIO'. {-# INLINE ciosUnitToLazyByteString #-} ciosUnitToLazyByteString :: AllocationStrategy - -> L.ByteString -> ChunkIOStream () -> L.ByteString + -> 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.ByteString' using 'unsafeDupablePerformIO'. +-- 'L.LazyByteString' using 'unsafeDupablePerformIO'. {-# INLINE ciosToLazyByteString #-} ciosToLazyByteString :: AllocationStrategy - -> (a -> (b, L.ByteString)) + -> (a -> (b, L.LazyByteString)) -> ChunkIOStream a - -> (b, L.ByteString) + -> (b, L.LazyByteString) ciosToLazyByteString strategy k = go where @@ -277,7 +275,7 @@ (BuildStep a) | InsertChunk {-# UNPACK #-} !(Ptr Word8) - S.ByteString + S.StrictByteString (BuildStep a) -- | Signal that the current 'BuildStep' is done and has computed a value. @@ -302,11 +300,11 @@ bufferFull = BufferFull --- | Signal that a 'S.ByteString' chunk should be inserted directly. +-- | Signal that a 'S.StrictByteString' chunk should be inserted directly. {-# INLINE insertChunk #-} insertChunk :: Ptr Word8 -- ^ Next free byte in current 'BufferRange' - -> S.ByteString + -> S.StrictByteString -- ^ Chunk to insert. -> BuildStep a -- ^ 'BuildStep' to run on next 'BufferRange' @@ -323,7 +321,7 @@ -- ^ Handling the 'done' signal -> (Ptr Word8 -> Int -> BuildStep a -> IO b) -- ^ Handling the 'bufferFull' signal - -> (Ptr Word8 -> S.ByteString -> BuildStep a -> IO b) + -> (Ptr Word8 -> S.StrictByteString -> BuildStep a -> IO b) -- ^ Handling the 'insertChunk' signal -> BufferRange -- ^ Buffer range to fill. @@ -359,7 +357,7 @@ -- 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. - -- Moroever, this function must call the continuation once its done. + -- 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 @@ -389,11 +387,14 @@ -- only exported for use in rewriting rules. Use 'mempty' otherwise. {-# INLINE[1] empty #-} empty :: Builder -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. @@ -401,24 +402,42 @@ append :: Builder -> Builder -> Builder append (Builder b1) (Builder b2) = Builder $ b1 . b2 -#if MIN_VERSION_base(4,9,0) +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 -#endif + sconcat (b:|bs) = b <> foldr mappend mempty bs + {-# INLINE stimes #-} + stimes = stimesBuilder instance Monoid Builder where {-# INLINE mempty #-} mempty = empty {-# INLINE mappend #-} -#if MIN_VERSION_base(4,9,0) mappend = (<>) -#else - mappend = append -#endif {-# 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 @@ -442,7 +461,7 @@ -- 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 reportng and handling such a failure in a pure +-- expressive enough to allow reporting and handling such a failure in a pure -- fashion. -- -- @'Put' ()@ actions are isomorphic to 'Builder's. The functions 'putBuilder' @@ -465,7 +484,7 @@ -- 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. Moroever, this function must call + -- 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 @@ -621,9 +640,9 @@ -- -- 1. GHC.IO.Handle.Internals mentions in "Note [async]" that -- we should never do any side-effecting operations before - -- an interuptible operation that may raise an async. exception + -- an interruptible operation that may raise an async. exception -- as long as we are inside 'wantWritableHandle' and the like. - -- We possibly run the interuptible 'flushWriteBuffer' right at + -- 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. -- @@ -705,7 +724,7 @@ fillHandle 1 nextStep -- | Execute a 'Put' and return the computed result and the bytes --- written during the computation as a lazy 'L.ByteString'. +-- 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 @@ -734,15 +753,15 @@ -- @ --type DecodingState = ... -- ---decodeBase64 :: 'S.ByteString' -> DecodingState -> 'Put' (Maybe DecodingState) +--decodeBase64 :: 'S.StrictByteString' -> DecodingState -> 'Put' (Maybe DecodingState) --decodeBase64 = ... -- @ -- --- The above function takes a strict 'S.ByteString' supposed to represent +-- 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.ByteString' was --- successful. The checking if the strict 'S.ByteString' represents Base64 +-- 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 @@ -752,7 +771,7 @@ {-# NOINLINE putToLazyByteString #-} putToLazyByteString :: Put a -- ^ 'Put' to execute - -> (a, L.ByteString) -- ^ Result and lazy 'L.ByteString' + -> (a, L.LazyByteString) -- ^ Result and 'L.LazyByteString' -- written as its side-effect putToLazyByteString = putToLazyByteStringWith (safeStrategy L.smallChunkSize L.defaultChunkSize) (, L.Empty) @@ -770,13 +789,13 @@ putToLazyByteStringWith :: AllocationStrategy -- ^ Buffer allocation strategy to use - -> (a -> (b, L.ByteString)) + -> (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.ByteString) - -- ^ Resulting lazy 'L.ByteString' + -> (b, L.LazyByteString) + -- ^ Resulting 'L.LazyByteString' putToLazyByteStringWith strategy k p = ciosToLazyByteString strategy k $ unsafeDupablePerformIO $ buildStepToCIOS strategy (runPut p) @@ -801,84 +820,132 @@ | ope `minusPtr` op < minFree = return $ bufferFull minFree op k | otherwise = k br --- | Copy the bytes from a 'BufferRange' into the output stream. -wrappedBytesCopyStep :: BufferRange -- ^ Input 'BufferRange'. +-- | Copy the bytes from a 'S.StrictByteString' into the output stream. +wrappedBytesCopyStep :: S.StrictByteString -- ^ Input 'S.StrictByteString'. -> BuildStep a -> BuildStep a -wrappedBytesCopyStep (BufferRange ip0 ipe) k = - go ip0 +-- See Note [byteStringCopyStep and wrappedBytesCopyStep] +wrappedBytesCopyStep bs0 k = + go bs0 where - go !ip (BufferRange op ope) + go !bs@(S.BS ifp inpRemaining) (BufferRange op ope) | inpRemaining <= outRemaining = do - copyBytes op ip inpRemaining + S.unsafeWithForeignPtr ifp $ \ip -> copyBytes op ip inpRemaining let !br' = BufferRange (op `plusPtr` inpRemaining) ope k br' | otherwise = do - copyBytes op ip outRemaining - let !ip' = ip `plusPtr` outRemaining - return $ bufferFull 1 ope (go ip') + 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 - inpRemaining = ipe `minusPtr` ip -- Strict ByteStrings ------------------------------------------------------------------------------ --- | Construct a 'Builder' that copies the strict 'S.ByteString's, if it is +-- | 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 strict 'S.ByteString's whose size +-- 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 lazy 'L.ByteString' may be as +-- 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, strict 'S.ByteString's. +-- directly inserted 1025 byte, 'S.StrictByteString's. -- {-# INLINE byteStringThreshold #-} -byteStringThreshold :: Int -> S.ByteString -> Builder +byteStringThreshold :: Int -> S.StrictByteString -> Builder byteStringThreshold maxCopySize = \bs -> builder $ step bs where - step bs@(S.BS _ len) !k br@(BufferRange !op _) + 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 strict 'S.ByteString'. +-- | Construct a 'Builder' that copies the 'S.StrictByteString'. -- -- Use this function to create 'Builder's from smallish (@<= 4kb@) --- 'S.ByteString's or if you need to guarantee that the 'S.ByteString' is not +-- '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.ByteString -> Builder +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.ByteString -> BuildStep a -> BuildStep a -byteStringCopyStep (S.BS ifp isize) !k0 br0@(BufferRange op ope) - -- Ensure that the common case is not recursive and therefore yields - -- better code. - | op' <= ope = do copyBytes op ip isize - touchForeignPtr ifp - k0 (BufferRange op' ope) - | otherwise = wrappedBytesCopyStep (BufferRange ip ipe) k br0 +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 - ip = unsafeForeignPtrToPtr ifp - ipe = ip `plusPtr` isize - k br = do touchForeignPtr ifp -- input consumed: OK to release here - k0 br --- | Construct a 'Builder' that always inserts the strict 'S.ByteString' +-- | 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.ByteString's. Otherwise, the generated chunks are too +-- (@> 8kb@) 'S.StrictByteString's. Otherwise, the generated chunks are too -- fragmented to be processed efficiently afterwards. -- {-# INLINE byteStringInsert #-} -byteStringInsert :: S.ByteString -> Builder +byteStringInsert :: S.StrictByteString -> Builder byteStringInsert = \bs -> builder $ \k (BufferRange op _) -> return $ insertChunk op bs k @@ -916,47 +983,47 @@ ------------------------------------------------------------------------------ -- | Construct a 'Builder' that uses the thresholding strategy of 'byteStringThreshold' --- for each chunk of the lazy 'L.ByteString'. +-- for each chunk of the 'L.LazyByteString'. -- {-# INLINE lazyByteStringThreshold #-} -lazyByteStringThreshold :: Int -> L.ByteString -> Builder +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 lazy 'L.ByteString'. +-- | Construct a 'Builder' that copies the 'L.LazyByteString'. -- {-# INLINE lazyByteStringCopy #-} -lazyByteStringCopy :: L.ByteString -> Builder +lazyByteStringCopy :: L.LazyByteString -> Builder lazyByteStringCopy = L.foldrChunks (\bs b -> byteStringCopy bs `mappend` b) mempty --- | Construct a 'Builder' that inserts all chunks of the lazy 'L.ByteString' +-- | Construct a 'Builder' that inserts all chunks of the 'L.LazyByteString' -- directly. -- {-# INLINE lazyByteStringInsert #-} -lazyByteStringInsert :: L.ByteString -> Builder +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 strict --- 'S.ByteString'. --- The 'Builder' inserts large 'S.ByteString's directly, but copies small ones +-- | 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.ByteString -> Builder +byteString :: S.StrictByteString -> Builder byteString = byteStringThreshold maximalCopySize -- | Create a 'Builder' denoting the same sequence of bytes as a lazy --- 'L.ByteString'. --- The 'Builder' inserts large chunks of the lazy 'L.ByteString' directly, +-- '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.ByteString -> Builder +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 @@ -964,7 +1031,7 @@ -- unnecessary buffer spilling. Hmm, but that uncontrollably increases latency -- => no good! --- | The maximal size of a 'S.ByteString' that is copied. +-- | 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 @@ -975,14 +1042,6 @@ ------------------------------------------------------------------------------ -- | A buffer allocation strategy for executing 'Builder's. - --- The strategy --- --- > 'AllocationStrategy' firstBufSize bufSize trim --- --- states that the first buffer is of size @firstBufSize@, all following buffers --- are of size @bufSize@, and a buffer of size @n@ filled with @k@ bytes should --- be trimmed iff @trim k n@ is 'True'. data AllocationStrategy = AllocationStrategy (Maybe (Buffer, Int) -> IO Buffer) {-# UNPACK #-} !Int @@ -993,11 +1052,20 @@ {-# 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 the @oldBuf@, if it can guarantee that this - -- referentially transparent and @oldBuf@ is large enough. + -- ^ 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) @@ -1011,7 +1079,7 @@ sanitize :: Int -> Int sanitize = max (sizeOf (undefined :: Int)) --- | Use this strategy for generating lazy 'L.ByteString's whose chunks are +-- | 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 #-} @@ -1028,7 +1096,7 @@ nextBuffer (Just (_, minSize)) = newBuffer minSize --- | Use this strategy for generating lazy 'L.ByteString's whose chunks are +-- | 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 #-} @@ -1045,19 +1113,27 @@ 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.toLazyByteString' is defined as follows. +-- function 'Data.ByteString.Builder.Internal.toLazyByteString' is defined as follows. -- -- @ -- {-\# NOINLINE toLazyByteString \#-} -- toLazyByteString = --- toLazyByteStringWith ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') L.empty +-- toLazyByteStringWith ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') L.Empty -- @ -- --- where @L.empty@ is the zero-length lazy 'L.ByteString'. +-- 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 @@ -1065,23 +1141,23 @@ -- 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 +-- >toLazyByteStringWith (safeStrategy 128 smallChunkSize) L.Empty -- -- This reduces the allocation and trimming overhead, as all generated --- 'L.ByteString's fit into the first buffer and there is no trimming +-- '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.ByteString - -- ^ Lazy 'L.ByteString' to use as the tail of the generated lazy - -- 'L.ByteString' + -> L.LazyByteString + -- ^ 'L.LazyByteString' to use as the tail of the generated lazy + -- 'L.LazyByteString' -> Builder -- ^ 'Builder' to execute - -> L.ByteString - -- ^ Resulting lazy 'L.ByteString' + -> L.LazyByteString + -- ^ Resulting 'L.LazyByteString' toLazyByteStringWith strategy k b = ciosUnitToLazyByteString strategy k $ unsafeDupablePerformIO $ buildStepToCIOS strategy (runBuilder b) @@ -1090,26 +1166,32 @@ -- 'Buffer's allocated according to the given 'AllocationStrategy'. {-# INLINE buildStepToCIOS #-} buildStepToCIOS - :: AllocationStrategy -- ^ Buffer allocation strategy to use + :: 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 @@ -1121,12 +1203,14 @@ -- 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.create chunkSize $ \pbuf' -> - copyBytes pbuf' pbuf chunkSize - -- FIXME: We could reuse the trimmed buffer here. + 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) diff --git a/Data/ByteString/Builder/Prim.hs b/Data/ByteString/Builder/Prim.hs --- a/Data/ByteString/Builder/Prim.hs +++ b/Data/ByteString/Builder/Prim.hs @@ -1,13 +1,5 @@ -{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} -{-# LANGUAGE MagicHash, UnboxedTuples, PatternGuards #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -#if __GLASGOW_HASKELL__ == 700 --- This is needed as a workaround for an old bug in GHC 7.0.1 (Trac #4498) -{-# LANGUAGE MonoPatBinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif + {- | Copyright : (c) 2010-2011 Simon Meier (c) 2010 Jasper van der Jeugt License : BSD3-style (see LICENSE) @@ -275,9 +267,9 @@ -- > map :: (Word8 -> Word8) -> ByteString -> ByteString -- > map f = toLazyByteString . encodeLazyByteStringWithB (E.word8 E.#. f) -- --- Compared to earlier versions of @filter@ and @map@ on lazy 'L.ByteString's, +-- 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.ByteString's; i.e, they +-- 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 @@ -404,7 +396,7 @@ -- which is implemented as follows. -- -- @ - -- byteStringHex :: S.ByteString -> Builder + -- byteStringHex :: S.StrictByteString -> Builder -- byteStringHex = 'primMapByteStringFixed' 'word8HexFixed' -- @ -- @@ -445,7 +437,7 @@ {- -- * Testing support -- | The following four functions are intended for testing use - -- only. They are /not/ efficient. Basic encodings are efficently executed by + -- 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. @@ -463,26 +455,15 @@ import qualified Data.ByteString.Internal as S import qualified Data.ByteString.Lazy.Internal as L -import Data.Monoid -import Data.Char (chr, ord) -import Control.Monad ((<=<), unless) +import Data.Char (ord) import Data.ByteString.Builder.Prim.Internal hiding (size, sizeBound) -import qualified Data.ByteString.Builder.Prim.Internal as I (size, sizeBound) +import qualified Data.ByteString.Builder.Prim.Internal as I import Data.ByteString.Builder.Prim.Binary import Data.ByteString.Builder.Prim.ASCII -#if MIN_VERSION_base(4,4,0) -#if MIN_VERSION_base(4,7,0) import Foreign -import Foreign.C.Types -#else -import Foreign hiding (unsafeForeignPtrToPtr) -#endif import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -#else -import Foreign -#endif import GHC.Word (Word8 (..)) import GHC.Exts import GHC.IO @@ -506,24 +487,24 @@ primUnfoldrFixed :: FixedPrim b -> (a -> Maybe (b, a)) -> a -> Builder primUnfoldrFixed = primUnfoldrBounded . toB --- | /Heavy inlining./ Encode all bytes of a strict 'S.ByteString' from +-- | /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.ByteString -> Builder +-- > mapToBuilder :: (Word8 -> Word8) -> S.StrictByteString -> Builder -- > mapToBuilder f = primMapByteStringFixed (contramapF f word8) -- --- We can also use it to hex-encode a strict 'S.ByteString' as shown by the +-- 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.ByteString -> Builder) +primMapByteStringFixed :: FixedPrim Word8 -> (S.StrictByteString -> Builder) primMapByteStringFixed = primMapByteStringBounded . toB --- | /Heavy inlining./ Encode all bytes of a lazy 'L.ByteString' from +-- | /Heavy inlining./ Encode all bytes of a 'L.LazyByteString' from -- left-to-right with a 'FixedPrim'. {-# INLINE primMapLazyByteStringFixed #-} -primMapLazyByteStringFixed :: FixedPrim Word8 -> (L.ByteString -> Builder) +primMapLazyByteStringFixed :: FixedPrim Word8 -> (L.LazyByteString -> Builder) primMapLazyByteStringFixed = primMapLazyByteStringBounded . toB -- IMPLEMENTATION NOTE: Sadly, 'encodeListWith' cannot be used for foldr/build @@ -544,11 +525,11 @@ -- at 8 free bytes, instead of checking twice, if there are 4 free bytes. This -- optimization is not observationally equivalent in a strict sense, as it -- influences the boundaries of the generated chunks. However, for a user of --- this library it is observationally equivalent, as chunk boundaries of a lazy --- 'L.ByteString' can only be observed through the internal interface. --- Morevoer, we expect that all primitives write much fewer than 4kb (the +-- 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 agressive buffer wrapping introduced by this +-- memory spilled due to the more aggressive buffer wrapping introduced by this -- optimization. -- {-# INLINE[1] primBounded #-} @@ -629,16 +610,16 @@ fillWith x' k (BufferRange opNew' opeNew) bound = I.sizeBound w --- | Create a 'Builder' that encodes each 'Word8' of a strict 'S.ByteString' +-- | Create a 'Builder' that encodes each 'Word8' of a 'S.StrictByteString' -- using a 'BoundedPrim'. For example, we can write a 'Builder' that filters --- a strict 'S.ByteString' as follows. +-- 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.ByteString -> Builder +primMapByteStringBounded :: BoundedPrim Word8 -> S.StrictByteString -> Builder primMapByteStringBounded w = \bs -> builder $ step bs where @@ -672,7 +653,7 @@ -- | Chunk-wise application of 'primMapByteStringBounded'. {-# INLINE primMapLazyByteStringBounded #-} -primMapLazyByteStringBounded :: BoundedPrim Word8 -> L.ByteString -> Builder +primMapLazyByteStringBounded :: BoundedPrim Word8 -> L.LazyByteString -> Builder primMapLazyByteStringBounded w = L.foldrChunks (\x b -> primMapByteStringBounded w x `mappend` b) mempty @@ -681,13 +662,10 @@ -- Raw CString encoding ------------------------------------------------------------------------------ -#if !MIN_VERSION_base(4,7,0) --- eqWord# et al. return Bools prior to GHC 7.6 -isTrue# :: Bool -> Bool -isTrue# x = x -#endif - --- | A null-terminated ASCII encoded 'CString'. Null characters are not representable. +-- | 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 @@ -696,7 +674,7 @@ step !addr !k br@(BufferRange op0@(Ptr op0#) ope) | W8# ch == 0 = k br | op0 == ope = - return $ bufferFull defaultChunkSize op0 (step addr k) + return $ bufferFull 1 op0 (step addr k) | otherwise = do IO $ \s -> case writeWord8OffAddr# op0# 0# ch s of s' -> (# s', () #) @@ -705,8 +683,10 @@ where !ch = indexWord8OffAddr# addr 0# --- | A null-terminated UTF-8 encoded 'CString'. Null characters can be encoded as --- @0xc0 0x80@. +-- | 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 @@ -715,7 +695,7 @@ step !addr !k br@(BufferRange op0@(Ptr op0#) ope) | W8# ch == 0 = k br | op0 == ope = - return $ bufferFull defaultChunkSize op0 (step addr k) + return $ bufferFull 1 op0 (step addr k) -- NULL is encoded as 0xc0 0x80 | W8# ch == 0xc0 , W8# (indexWord8OffAddr# addr 1#) == 0x80 = do diff --git a/Data/ByteString/Builder/Prim/ASCII.hs b/Data/ByteString/Builder/Prim/ASCII.hs --- a/Data/ByteString/Builder/Prim/ASCII.hs +++ b/Data/ByteString/Builder/Prim/ASCII.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif -- | Copyright : (c) 2010 Jasper Van der Jeugt -- (c) 2010 - 2011 Simon Meier -- License : BSD3-style (see LICENSE) @@ -80,15 +75,16 @@ ) 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 -import Foreign.C.Types -- | Encode the least 7-bits of a 'Char' using the ASCII encoding. {-# INLINE char7 #-} @@ -103,12 +99,6 @@ -- Signed integers ------------------ -foreign import ccall unsafe "static _hs_bytestring_int_dec" c_int_dec - :: CInt -> Ptr Word8 -> IO (Ptr Word8) - -foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec" c_long_long_int_dec - :: CLLong -> Ptr Word8 -> IO (Ptr Word8) - {-# INLINE encodeIntDecimal #-} encodeIntDecimal :: Integral a => Int -> BoundedPrim a encodeIntDecimal bound = boundedPrim bound $ c_int_dec . fromIntegral @@ -145,12 +135,6 @@ -- Unsigned integers -------------------- -foreign import ccall unsafe "static _hs_bytestring_uint_dec" c_uint_dec - :: CUInt -> Ptr Word8 -> IO (Ptr Word8) - -foreign import ccall unsafe "static _hs_bytestring_long_long_uint_dec" c_long_long_uint_dec - :: CULLong -> Ptr Word8 -> IO (Ptr Word8) - {-# INLINE encodeWordDecimal #-} encodeWordDecimal :: Integral a => Int -> BoundedPrim a encodeWordDecimal bound = boundedPrim bound $ c_uint_dec . fromIntegral @@ -189,12 +173,6 @@ -- without lead --------------- -foreign import ccall unsafe "static _hs_bytestring_uint_hex" c_uint_hex - :: CUInt -> Ptr Word8 -> IO (Ptr Word8) - -foreign import ccall unsafe "static _hs_bytestring_long_long_uint_hex" c_long_long_uint_hex - :: CULLong -> Ptr Word8 -> IO (Ptr Word8) - {-# INLINE encodeWordHex #-} encodeWordHex :: forall a. (Storable a, Integral a) => BoundedPrim a encodeWordHex = @@ -234,8 +212,9 @@ -- | Encode a 'Word8' using 2 nibbles (hexadecimal digits). {-# INLINE word8HexFixed #-} word8HexFixed :: FixedPrim Word8 -word8HexFixed = fixedPrim 2 $ - \x op -> poke (castPtr op) =<< encode8_as_16h lowerTable x +word8HexFixed = fixedPrim 2 $ \x op -> do + enc <- encode8_as_16h lowerTable x + unalignedWriteU16 enc op -- | Encode a 'Word16' using 4 nibbles. {-# INLINE word16HexFixed #-} @@ -250,6 +229,7 @@ word32HexFixed = (\x -> (fromIntegral $ x `shiftR` 16, fromIntegral x)) >$< pairF word16HexFixed word16HexFixed + -- | Encode a 'Word64' using 16 nibbles. {-# INLINE word64HexFixed #-} word64HexFixed :: FixedPrim Word64 diff --git a/Data/ByteString/Builder/Prim/Binary.hs b/Data/ByteString/Builder/Prim/Binary.hs --- a/Data/ByteString/Builder/Prim/Binary.hs +++ b/Data/ByteString/Builder/Prim/Binary.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif + -- | Copyright : (c) 2010-2011 Simon Meier -- License : BSD3-style (see LICENSE) -- @@ -56,11 +54,11 @@ 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 -#include "MachDeps.h" - ------------------------------------------------------------------------------ -- Binary encoding ------------------------------------------------------------------------------ @@ -72,7 +70,7 @@ -- {-# INLINE word8 #-} word8 :: FixedPrim Word8 -word8 = storableToF +word8 = fixedPrim 1 (flip poke) -- Word8 is always aligned -- -- We rely on the fromIntegral to do the right masking for us. @@ -82,50 +80,22 @@ -- | Encoding 'Word16's in big endian format. {-# INLINE word16BE #-} word16BE :: FixedPrim Word16 -#ifdef WORDS_BIGENDIAN -word16BE = word16Host -#else -word16BE = fixedPrim 2 $ \w p -> do - poke p (fromIntegral (shiftR w 8) :: Word8) - poke (p `plusPtr` 1) (fromIntegral w :: Word8) -#endif +word16BE = whenLittleEndian byteSwap16 >$< word16Host -- | Encoding 'Word16's in little endian format. {-# INLINE word16LE #-} word16LE :: FixedPrim Word16 -#ifdef WORDS_BIGENDIAN -word16LE = fixedPrim 2 $ \w p -> do - poke p (fromIntegral w :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftR w 8) :: Word8) -#else -word16LE = word16Host -#endif +word16LE = whenBigEndian byteSwap16 >$< word16Host -- | Encoding 'Word32's in big endian format. {-# INLINE word32BE #-} word32BE :: FixedPrim Word32 -#ifdef WORDS_BIGENDIAN -word32BE = word32Host -#else -word32BE = fixedPrim 4 $ \w p -> do - poke p (fromIntegral (shiftR w 24) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftR w 16) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftR w 8) :: Word8) - poke (p `plusPtr` 3) (fromIntegral w :: Word8) -#endif +word32BE = whenLittleEndian byteSwap32 >$< word32Host -- | Encoding 'Word32's in little endian format. {-# INLINE word32LE #-} word32LE :: FixedPrim Word32 -#ifdef WORDS_BIGENDIAN -word32LE = fixedPrim 4 $ \w p -> do - poke p (fromIntegral w :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftR w 8) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftR w 16) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftR w 24) :: Word8) -#else -word32LE = word32Host -#endif +word32LE = whenBigEndian byteSwap32 >$< word32Host -- on a little endian machine: -- word32LE w32 = fixedPrim 4 (\w p -> poke (castPtr p) w32) @@ -133,70 +103,12 @@ -- | Encoding 'Word64's in big endian format. {-# INLINE word64BE #-} word64BE :: FixedPrim Word64 -#ifdef WORDS_BIGENDIAN -word64BE = word64Host -#else -#if WORD_SIZE_IN_BITS < 64 --- --- To avoid expensive 64 bit shifts on 32 bit machines, we cast to --- Word32, and write that --- -word64BE = - fixedPrim 8 $ \w p -> do - let a = fromIntegral (shiftR w 32) :: Word32 - b = fromIntegral w :: Word32 - poke p (fromIntegral (shiftR a 24) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftR a 16) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftR a 8) :: Word8) - poke (p `plusPtr` 3) (fromIntegral a :: Word8) - poke (p `plusPtr` 4) (fromIntegral (shiftR b 24) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftR b 16) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftR b 8) :: Word8) - poke (p `plusPtr` 7) (fromIntegral b :: Word8) -#else -word64BE = fixedPrim 8 $ \w p -> do - poke p (fromIntegral (shiftR w 56) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftR w 48) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftR w 40) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftR w 32) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (shiftR w 24) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftR w 16) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftR w 8) :: Word8) - poke (p `plusPtr` 7) (fromIntegral w :: Word8) -#endif -#endif +word64BE = whenLittleEndian byteSwap64 >$< word64Host -- | Encoding 'Word64's in little endian format. {-# INLINE word64LE #-} word64LE :: FixedPrim Word64 -#ifdef WORDS_BIGENDIAN -#if WORD_SIZE_IN_BITS < 64 -word64LE = - fixedPrim 8 $ \w p -> do - let b = fromIntegral (shiftR w 32) :: Word32 - a = fromIntegral w :: Word32 - poke (p) (fromIntegral a :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftR a 8) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftR a 16) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftR a 24) :: Word8) - poke (p `plusPtr` 4) (fromIntegral b :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftR b 8) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftR b 16) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (shiftR b 24) :: Word8) -#else -word64LE = fixedPrim 8 $ \w p -> do - poke p (fromIntegral w :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftR w 8) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftR w 16) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftR w 24) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (shiftR w 32) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftR w 40) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftR w 48) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (shiftR w 56) :: Word8) -#endif -#else -word64LE = word64Host -#endif +word64LE = whenBigEndian byteSwap64 >$< word64Host -- | Encode a single native machine 'Word'. The 'Word's is encoded in host order, @@ -207,23 +119,25 @@ -- {-# INLINE wordHost #-} wordHost :: FixedPrim Word -wordHost = storableToF +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 = storableToF +word16Host = fixedPrim 2 unalignedWriteU16 -- | Encoding 'Word32's in native host order and host endianness. {-# INLINE word32Host #-} word32Host :: FixedPrim Word32 -word32Host = storableToF +word32Host = fixedPrim 4 unalignedWriteU32 -- | Encoding 'Word64's in native host order and host endianness. {-# INLINE word64Host #-} word64Host :: FixedPrim Word64 -word64Host = storableToF - +word64Host = fixedPrim 8 unalignedWriteU64 ------------------------------------------------------------------------------ -- Int encodings @@ -279,22 +193,22 @@ -- {-# INLINE intHost #-} intHost :: FixedPrim Int -intHost = storableToF +intHost = fromIntegral @Int @Word >$< wordHost -- | Encoding 'Int16's in native host order and host endianness. {-# INLINE int16Host #-} int16Host :: FixedPrim Int16 -int16Host = storableToF +int16Host = fromIntegral @Int16 @Word16 >$< word16Host -- | Encoding 'Int32's in native host order and host endianness. {-# INLINE int32Host #-} int32Host :: FixedPrim Int32 -int32Host = storableToF +int32Host = fromIntegral @Int32 @Word32 >$< word32Host -- | Encoding 'Int64's in native host order and host endianness. {-# INLINE int64Host #-} int64Host :: FixedPrim Int64 -int64Host = storableToF +int64Host = fromIntegral @Int64 @Word64 >$< word64Host -- IEEE Floating Point Numbers ------------------------------ @@ -325,9 +239,9 @@ -- {-# INLINE floatHost #-} floatHost :: FixedPrim Float -floatHost = storableToF +floatHost = fixedPrim (sizeOf @Float 0) unalignedWriteFloat -- | Encode a 'Double' in native host order and host endianness. {-# INLINE doubleHost #-} doubleHost :: FixedPrim Double -doubleHost = storableToF +doubleHost = fixedPrim (sizeOf @Double 0) unalignedWriteDouble diff --git a/Data/ByteString/Builder/Prim/Internal.hs b/Data/ByteString/Builder/Prim/Internal.hs --- a/Data/ByteString/Builder/Prim/Internal.hs +++ b/Data/ByteString/Builder/Prim/Internal.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE ScopedTypeVariables, CPP #-} -#if __GLASGOW_HASKELL__ >= 703 +{-# LANGUAGE CPP #-} {-# LANGUAGE Unsafe #-} -#endif + {-# OPTIONS_HADDOCK not-home #-} + -- | -- Copyright : 2010-2011 Simon Meier, 2010 Jasper van der Jeugt -- License : BSD3-style (see LICENSE) @@ -75,6 +75,7 @@ import Prelude hiding (maxBound) #include "MachDeps.h" +#include "bytestring-cpp-macros.h" ------------------------------------------------------------------------------ -- Supporting infrastructure @@ -200,14 +201,11 @@ 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 --- Not all architectures are forgiving of unaligned accesses; whitelist ones --- which are known not to trap (either to the kernel for emulation, or crash). -#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) +#if HS_UNALIGNED_POKES_OK storableToF = FP (sizeOf (undefined :: a)) (\x op -> poke (castPtr op) x) #else storableToF = FP (sizeOf (undefined :: a)) $ \x op -> diff --git a/Data/ByteString/Builder/Prim/Internal/Base16.hs b/Data/ByteString/Builder/Prim/Internal/Base16.hs --- a/Data/ByteString/Builder/Prim/Internal/Base16.hs +++ b/Data/ByteString/Builder/Prim/Internal/Base16.hs @@ -1,7 +1,5 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif + -- | -- Copyright : (c) 2011 Simon Meier -- License : BSD3-style (see LICENSE) @@ -24,57 +22,39 @@ , encode8_as_16h ) where -import qualified Data.ByteString as S -import qualified Data.ByteString.Internal as S - -#if MIN_VERSION_base(4,4,0) -#if MIN_VERSION_base(4,7,0) -import Foreign -#else -import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr) -#endif -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import System.IO.Unsafe (unsafePerformIO) +import Foreign +import GHC.Exts (Addr#, Ptr(..)) +#if PURE_HASKELL +import qualified Data.ByteString.Internal.Pure as Pure #else -import Foreign +import Foreign.C.Types #endif -- Creating the encoding table ------------------------------ --- TODO: Use table from C implementation. - -- | An encoding table for Base16 encoding. -newtype EncodingTable = EncodingTable (ForeignPtr Word8) - -tableFromList :: [Word8] -> EncodingTable -tableFromList xs = case S.pack xs of S.BS fp _ -> EncodingTable fp - -unsafeIndex :: EncodingTable -> Int -> IO Word8 -unsafeIndex (EncodingTable table) = peekElemOff (unsafeForeignPtrToPtr table) - -base16EncodingTable :: EncodingTable -> IO EncodingTable -base16EncodingTable alphabet = do - xs <- sequence $ concat $ [ [ix j, ix k] | j <- [0..15], k <- [0..15] ] - return $ tableFromList xs - where - ix = unsafeIndex alphabet - -{-# NOINLINE lowerAlphabet #-} -lowerAlphabet :: EncodingTable -lowerAlphabet = - tableFromList $ map (fromIntegral . fromEnum) $ ['0'..'9'] ++ ['a'..'f'] +data EncodingTable = EncodingTable Addr# -- | The encoding table for hexadecimal values with lower-case characters; -- e.g., deadbeef. -{-# NOINLINE lowerTable #-} lowerTable :: EncodingTable -lowerTable = unsafePerformIO $ base16EncodingTable lowerAlphabet +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 (castPtr $ unsafeForeignPtrToPtr table) . fromIntegral + peekElemOff (Ptr table) . fromIntegral diff --git a/Data/ByteString/Builder/Prim/Internal/Floating.hs b/Data/ByteString/Builder/Prim/Internal/Floating.hs --- a/Data/ByteString/Builder/Prim/Internal/Floating.hs +++ b/Data/ByteString/Builder/Prim/Internal/Floating.hs @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif + +#include "MachDeps.h" +#include "bytestring-cpp-macros.h" + -- | -- Copyright : (c) 2010 Simon Meier -- @@ -15,45 +15,74 @@ -- Conversion of 'Float's and 'Double's to 'Word32's and 'Word64's. -- module Data.ByteString.Builder.Prim.Internal.Floating - ( - -- coerceFloatToWord32 - -- , coerceDoubleToWord64 - encodeFloatViaWord32F + ( castFloatToWord32 + , castDoubleToWord64 + , encodeFloatViaWord32F , encodeDoubleViaWord64F ) where -import Foreign 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 using the -FFI to store the Float/Double in the buffer and peek it out again from there. +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)) --- | Encode a 'Float' using a 'Word32' encoding. +-- | Interpret a 'Double' as a 'Word64' as if through a bit-for-bit copy. +-- (fallback if not available through GHC.Float) -- --- PRE: The 'Word32' encoding must have a size of at least 4 bytes. +-- 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 -encodeFloatViaWord32F w32fe - | size w32fe < sizeOf (undefined :: Float) = - error "encodeFloatViaWord32F: encoding not wide enough" - | otherwise = fixedPrim (size w32fe) $ \x op -> do - poke (castPtr op) x - x' <- peek (castPtr op) - runF w32fe x' op +#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. --- --- PRE: The 'Word64' encoding must have a size of at least 8 bytes. {-# INLINE encodeDoubleViaWord64F #-} encodeDoubleViaWord64F :: FixedPrim Word64 -> FixedPrim Double -encodeDoubleViaWord64F w64fe - | size w64fe < sizeOf (undefined :: Float) = - error "encodeDoubleViaWord64F: encoding not wide enough" - | otherwise = fixedPrim (size w64fe) $ \x op -> do - poke (castPtr op) x - x' <- peek (castPtr op) - runF w64fe x' op - +#if HS_CAST_FLOAT_WORD_OPS_AVAILABLE +encodeDoubleViaWord64F = (castDoubleToWord64 >$<) +#else +encodeDoubleViaWord64F w64fe = fixedPrim (size w64fe) $ \x op -> do + x' <- with x (peek . castPtr) + runF w64fe x' op +#endif diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/RealFloat.hs @@ -0,0 +1,287 @@ +-- | +-- Module : Data.ByteString.Builder.RealFloat +-- Copyright : (c) Lawrence Wu 2021 +-- License : BSD-style +-- Maintainer : lawrencejwu@gmail.com +-- +-- Floating point formatting for @Bytestring.Builder@ +-- +-- This module primarily exposes `floatDec` and `doubleDec` which do the +-- equivalent of converting through @'Data.ByteString.Builder.string7' . 'show'@. +-- +-- It also exposes `formatFloat` and `formatDouble` with a similar API as +-- `GHC.Float.formatRealFloat`. +-- +-- NB: The float-to-string conversions exposed by this module match `show`'s +-- output (specifically with respect to default rounding and length). In +-- particular, there are boundary cases where the closest and \'shortest\' +-- string representations are not used. Mentions of \'shortest\' in the docs +-- below are with this caveat. +-- +-- For example, for fidelity, we match `show` on the output below. +-- +-- >>> show (1.0e23 :: Float) +-- "1.0e23" +-- >>> show (1.0e23 :: Double) +-- "9.999999999999999e22" +-- >>> floatDec 1.0e23 +-- "1.0e23" +-- >>> doubleDec 1.0e23 +-- "9.999999999999999e22" +-- +-- Simplifying, we can build a shorter, lossless representation by just using +-- @"1.0e23"@ since the floating point values that are 1 ULP away are +-- +-- >>> showHex (castDoubleToWord64 1.0e23) [] +-- "44b52d02c7e14af6" +-- >>> castWord64ToDouble 0x44b52d02c7e14af5 +-- 9.999999999999997e22 +-- >>> castWord64ToDouble 0x44b52d02c7e14af6 +-- 9.999999999999999e22 +-- >>> castWord64ToDouble 0x44b52d02c7e14af7 +-- 1.0000000000000001e23 +-- +-- In particular, we could use the exact boundary if it is the shortest +-- representation and the original floating number is even. To experiment with +-- the shorter rounding, refer to +-- `Data.ByteString.Builder.RealFloat.Internal.acceptBounds`. This will give us +-- +-- >>> floatDec 1.0e23 +-- "1.0e23" +-- >>> doubleDec 1.0e23 +-- "1.0e23" +-- +-- For more details, please refer to the +-- . +-- +-- @since 0.11.2.0 + +module Data.ByteString.Builder.RealFloat + ( floatDec + , doubleDec + + -- * Custom formatting + , formatFloat + , formatDouble + , FloatFormat + , standard + , standardDefaultPrecision + , scientific + , generic + ) where + +import Data.ByteString.Builder.Internal (Builder) +import qualified Data.ByteString.Builder.RealFloat.Internal as R +import qualified Data.ByteString.Builder.RealFloat.F2S as RF +import qualified Data.ByteString.Builder.RealFloat.D2S as RD +import qualified Data.ByteString.Builder.Prim as BP +import GHC.Float (roundTo) +import GHC.Word (Word64) +import GHC.Show (intToDigit) + +-- | Returns a rendered Float. Matches `show` in displaying in standard or +-- scientific notation +-- +-- @ +-- floatDec = 'formatFloat' 'generic' +-- @ +{-# INLINABLE floatDec #-} +floatDec :: Float -> Builder +floatDec = formatFloat generic + +-- | Returns a rendered Double. Matches `show` in displaying in standard or +-- scientific notation +-- +-- @ +-- doubleDec = 'formatDouble' 'generic' +-- @ +{-# INLINABLE doubleDec #-} +doubleDec :: Double -> Builder +doubleDec = formatDouble generic + +-- | Format type for use with `formatFloat` and `formatDouble`. +-- +-- @since 0.11.2.0 +data FloatFormat = MkFloatFormat FormatMode (Maybe Int) + +-- | Standard notation with `n` decimal places +-- +-- @since 0.11.2.0 +standard :: Int -> FloatFormat +standard n = MkFloatFormat FStandard (Just n) + +-- | Standard notation with the \'default precision\' (decimal places matching `show`) +-- +-- @since 0.11.2.0 +standardDefaultPrecision :: FloatFormat +standardDefaultPrecision = MkFloatFormat FStandard Nothing + +-- | Scientific notation with \'default precision\' (decimal places matching `show`) +-- +-- @since 0.11.2.0 +scientific :: FloatFormat +scientific = MkFloatFormat FScientific Nothing + +-- | Standard or scientific notation depending on the exponent. Matches `show` +-- +-- @since 0.11.2.0 +generic :: FloatFormat +generic = MkFloatFormat FGeneric Nothing + +-- | ByteString float-to-string format +data FormatMode + = FScientific -- ^ scientific notation + | FStandard -- ^ standard notation with `Maybe Int` digits after the decimal + | FGeneric -- ^ dispatches to scientific or standard notation based on the exponent + deriving Show + +-- TODO: support precision argument for FGeneric and FScientific +-- | Returns a rendered Float. Returns the \'shortest\' representation in +-- scientific notation and takes an optional precision argument in standard +-- notation. Also see `floatDec`. +-- +-- With standard notation, the precision argument is used to truncate (or +-- extend with 0s) the \'shortest\' rendered Float. The \'default precision\' does +-- no such modifications and will return as many decimal places as the +-- representation demands. +-- +-- e.g +-- +-- >>> formatFloat (standard 1) 1.2345e-2 +-- "0.0" +-- >>> formatFloat (standard 10) 1.2345e-2 +-- "0.0123450000" +-- >>> formatFloat standardDefaultPrecision 1.2345e-2 +-- "0.01234" +-- >>> formatFloat scientific 12.345 +-- "1.2345e1" +-- >>> formatFloat generic 12.345 +-- "12.345" +-- +-- @since 0.11.2.0 +{-# INLINABLE formatFloat #-} +formatFloat :: FloatFormat -> Float -> Builder +formatFloat (MkFloatFormat fmt prec) = \f -> + let (RF.FloatingDecimal m e) = RF.f2Intermediate f + e' = R.int32ToInt e + R.decimalLength9 m in + case fmt of + FGeneric -> + case specialStr f of + Just b -> b + Nothing -> + if e' >= 0 && e' <= 7 + then sign f `mappend` showStandard (R.word32ToWord64 m) e' prec + else BP.primBounded (R.toCharsScientific (f < 0) m e) () + FScientific -> RF.f2s f + FStandard -> + case specialStr f of + Just b -> b + Nothing -> sign f `mappend` showStandard (R.word32ToWord64 m) e' prec + +-- TODO: support precision argument for FGeneric and FScientific +-- | Returns a rendered Double. Returns the \'shortest\' representation in +-- scientific notation and takes an optional precision argument in standard +-- notation. Also see `doubleDec`. +-- +-- With standard notation, the precision argument is used to truncate (or +-- extend with 0s) the \'shortest\' rendered Float. The \'default precision\' +-- does no such modifications and will return as many decimal places as the +-- representation demands. +-- +-- e.g +-- +-- >>> formatDouble (standard 1) 1.2345e-2 +-- "0.0" +-- >>> formatDouble (standard 10) 1.2345e-2 +-- "0.0123450000" +-- >>> formatDouble standardDefaultPrecision 1.2345e-2 +-- "0.01234" +-- >>> formatDouble scientific 12.345 +-- "1.2345e1" +-- >>> formatDouble generic 12.345 +-- "12.345" +-- +-- @since 0.11.2.0 +{-# INLINABLE formatDouble #-} +formatDouble :: FloatFormat -> Double -> Builder +formatDouble (MkFloatFormat fmt prec) = \f -> + let (RD.FloatingDecimal m e) = RD.d2Intermediate f + e' = R.int32ToInt e + R.decimalLength17 m in + case fmt of + FGeneric -> + case specialStr f of + Just b -> b + Nothing -> + if e' >= 0 && e' <= 7 + then sign f `mappend` showStandard m e' prec + else BP.primBounded (R.toCharsScientific (f < 0) m e) () + FScientific -> RD.d2s f + FStandard -> + case specialStr f of + Just b -> b + Nothing -> sign f `mappend` showStandard m e' prec + +-- | Char7 encode a 'Char'. +{-# INLINE char7 #-} +char7 :: Char -> Builder +char7 = BP.primFixed BP.char7 + +-- | Char7 encode a 'String'. +{-# INLINE string7 #-} +string7 :: String -> Builder +string7 = BP.primMapListFixed BP.char7 + +-- | Encodes a `-` if input is negative +sign :: RealFloat a => a -> Builder +sign f = if f < 0 then char7 '-' else mempty + +-- | Special rendering for Nan, Infinity, and 0. See +-- RealFloat.Internal.NonNumbersAndZero +specialStr :: RealFloat a => a -> Maybe Builder +specialStr f + | isNaN f = Just $ string7 "NaN" + | isInfinite f = Just $ sign f `mappend` string7 "Infinity" + | isNegativeZero f = Just $ string7 "-0.0" + | f == 0 = Just $ string7 "0.0" + | otherwise = Nothing + +-- | Returns a list of decimal digits in a Word64 +digits :: Word64 -> [Int] +digits w = go [] w + where go ds 0 = ds + go ds c = let (q, r) = R.dquotRem10 c + in go ((R.word64ToInt r) : ds) q + +-- | Show a floating point value in standard notation. Based on GHC.Float.showFloat +showStandard :: Word64 -> Int -> Maybe Int -> Builder +showStandard m e prec = + case prec of + Nothing + | e <= 0 -> char7 '0' + `mappend` char7 '.' + `mappend` string7 (replicate (-e) '0') + `mappend` mconcat (digitsToBuilder ds) + | otherwise -> + let f 0 s rs = mk0 (reverse s) `mappend` char7 '.' `mappend` mk0 rs + f n s [] = f (n-1) (char7 '0':s) [] + f n s (r:rs) = f (n-1) (r:s) rs + in f e [] (digitsToBuilder ds) + Just p + | e >= 0 -> + let (ei, is') = roundTo 10 (p' + e) ds + (ls, rs) = splitAt (e + ei) (digitsToBuilder is') + in mk0 ls `mappend` mkDot rs + | otherwise -> + let (ei, is') = roundTo 10 p' (replicate (-e) 0 ++ ds) + -- ds' should always be non-empty but use redundant pattern + -- matching to silence warning + ds' = if ei > 0 then is' else 0:is' + (ls, rs) = splitAt 1 $ digitsToBuilder ds' + in mk0 ls `mappend` mkDot rs + where p' = max p 0 + where + mk0 ls = case ls of [] -> char7 '0'; _ -> mconcat ls + mkDot rs = if null rs then mempty else char7 '.' `mappend` mconcat rs + ds = digits m + digitsToBuilder = fmap (char7 . intToDigit) + diff --git a/Data/ByteString/Builder/RealFloat/D2S.hs b/Data/ByteString/Builder/RealFloat/D2S.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/RealFloat/D2S.hs @@ -0,0 +1,863 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Data.ByteString.Builder.RealFloat.D2S +-- Copyright : (c) Lawrence Wu 2021 +-- License : BSD-style +-- Maintainer : lawrencejwu@gmail.com +-- +-- Implementation of double-to-string conversion + +module Data.ByteString.Builder.RealFloat.D2S + ( FloatingDecimal(..) + , d2s + , d2Intermediate + ) where + +import Control.Arrow (first) +import Data.Bits ((.|.), (.&.), unsafeShiftL, unsafeShiftR) +import Data.ByteString.Builder.Internal (Builder) +import Data.ByteString.Builder.Prim (primBounded) +import Data.ByteString.Builder.RealFloat.Internal +import Data.Maybe (fromMaybe) +import GHC.Int (Int32(..)) +import GHC.Word (Word64(..)) + +#if !PURE_HASKELL +import GHC.Ptr (Ptr(..)) +#endif + +-- See Data.ByteString.Builder.RealFloat.TableGenerator for a high-level +-- explanation of the ryu algorithm + +#if !PURE_HASKELL +-- | Table of 2^k / 5^q + 1 +-- +-- > splitWord128s $ fmap (finv double_pow5_inv_bitcount) [0..double_max_inv_split] +foreign import ccall "&hs_bytestring_double_pow5_inv_split" + double_pow5_inv_split :: Ptr Word64 + +-- | Table of 5^(-e2-q) / 2^k + 1 +-- +-- > splitWord128s $ fmap (fnorm double_pow5_bitcount) [0..double_max_split] +foreign import ccall "&hs_bytestring_double_pow5_split" + double_pow5_split :: Ptr Word64 +#endif + +-- | Number of mantissa bits of a 64-bit float. The number of significant bits +-- (floatDigits (undefined :: Double)) is 53 since we have a leading 1 for +-- normal floats and 0 for subnormal floats +double_mantissa_bits :: Int +double_mantissa_bits = 52 + +-- | Number of exponent bits of a 64-bit float +double_exponent_bits :: Int +double_exponent_bits = 11 + +-- | Bias in encoded 64-bit float representation (2^10 - 1) +double_bias :: Int +double_bias = 1023 + +data FloatingDecimal = FloatingDecimal + { dmantissa :: !Word64 + , dexponent :: !Int32 + } deriving (Show, Eq) + +-- | Quick check for small integers +d2dSmallInt :: Word64 -> Word64 -> Maybe FloatingDecimal +d2dSmallInt m e = + let m2 = (1 `unsafeShiftL` double_mantissa_bits) .|. m + e2 = word64ToInt e - (double_bias + double_mantissa_bits) + fraction = m2 .&. mask (-e2) + in case () of + _ -- f = m2 * 2^e2 >= 2^53 is an integer. + -- Ignore this case for now. + | e2 > 0 -> Nothing + -- f < 1 + | e2 < -52 -> Nothing + -- Since 2^52 <= m2 < 2^53 and 0 <= -e2 <= 52: + -- 1 <= f = m2 / 2^-e2 < 2^53. + -- Test if the lower -e2 bits of the significand are 0, i.e. + -- whether the fraction is 0. + | fraction /= 0 -> Nothing + -- f is an integer in the range [1, 2^53). + -- Note: mantissa might contain trailing (decimal) 0's. + -- Note: since 2^53 < 10^16, there is no need to adjust decimalLength17(). + | otherwise -> Just $ FloatingDecimal (m2 `unsafeShiftR` (-e2)) 0 + + +-- | Removes trailing (decimal) zeros for small integers in the range [1, 2^53) +unifySmallTrailing :: FloatingDecimal -> FloatingDecimal +unifySmallTrailing fd@(FloatingDecimal m e) = + let !(q, r) = dquotRem10 m + in if r == 0 + then unifySmallTrailing $ FloatingDecimal q (e + 1) + else fd + +-- TODO: 128-bit intrinsics +-- | Multiply a 64-bit number with a 128-bit number while keeping the upper 64 +-- bits. Then shift by specified amount minus 64 +mulShift64 :: Word64 -> (Word64, Word64) -> Int -> Word64 +mulShift64 m (factorHi, factorLo) shift = + let !(b0Hi, _ ) = m `timesWord2` factorLo + !(b1Hi, b1Lo) = m `timesWord2` factorHi + total = b0Hi + b1Lo + high = b1Hi + boolToWord64 (total < b0Hi) + dist = shift - 64 + in (high `unsafeShiftL` (64 - dist)) .|. (total `unsafeShiftR` dist) + +-- | Index into the 128-bit word lookup table double_pow5_inv_split +get_double_pow5_inv_split :: Int -> (Word64, Word64) +#if !PURE_HASKELL +get_double_pow5_inv_split = getWord128At double_pow5_inv_split +#else +-- > putStr $ case128 (finv double_pow5_inv_bitcount) [0..double_max_inv_split] +get_double_pow5_inv_split i = case i of + 0 -> (0x2000000000000000, 0x1) + 1 -> (0x1999999999999999, 0x999999999999999a) + 2 -> (0x147ae147ae147ae1, 0x47ae147ae147ae15) + 3 -> (0x10624dd2f1a9fbe7, 0x6c8b4395810624de) + 4 -> (0x1a36e2eb1c432ca5, 0x7a786c226809d496) + 5 -> (0x14f8b588e368f084, 0x61f9f01b866e43ab) + 6 -> (0x10c6f7a0b5ed8d36, 0xb4c7f34938583622) + 7 -> (0x1ad7f29abcaf4857, 0x87a6520ec08d236a) + 8 -> (0x15798ee2308c39df, 0x9fb841a566d74f88) + 9 -> (0x112e0be826d694b2, 0xe62d01511f12a607) + 10 -> (0x1b7cdfd9d7bdbab7, 0xd6ae6881cb5109a4) + 11 -> (0x15fd7fe17964955f, 0xdef1ed34a2a73aea) + 12 -> (0x119799812dea1119, 0x7f27f0f6e885c8bb) + 13 -> (0x1c25c268497681c2, 0x650cb4be40d60df8) + 14 -> (0x16849b86a12b9b01, 0xea70909833de7193) + 15 -> (0x1203af9ee756159b, 0x21f3a6e0297ec143) + 16 -> (0x1cd2b297d889bc2b, 0x6985d7cd0f313537) + 17 -> (0x170ef54646d49689, 0x2137dfd73f5a90f9) + 18 -> (0x12725dd1d243aba0, 0xe75fe645cc4873fa) + 19 -> (0x1d83c94fb6d2ac34, 0xa5663d3c7a0d865d) + 20 -> (0x179ca10c9242235d, 0x511e976394d79eb1) + 21 -> (0x12e3b40a0e9b4f7d, 0xda7edf82dd794bc1) + 22 -> (0x1e392010175ee596, 0x2a6498d1625bac68) + 23 -> (0x182db34012b25144, 0xeeb6e0a781e2f053) + 24 -> (0x1357c299a88ea76a, 0x58924d52ce4f26a9) + 25 -> (0x1ef2d0f5da7dd8aa, 0x27507bb7b07ea441) + 26 -> (0x18c240c4aecb13bb, 0x52a6c95fc0655034) + 27 -> (0x13ce9a36f23c0fc9, 0xeebd44c99eaa690) + 28 -> (0x1fb0f6be50601941, 0xb17953adc3110a80) + 29 -> (0x195a5efea6b34767, 0xc12ddc8b02740867) + 30 -> (0x14484bfeebc29f86, 0x3424b06f3529a052) + 31 -> (0x1039d66589687f9e, 0x901d59f290ee19db) + 32 -> (0x19f623d5a8a73297, 0x4cfbc31db4b0295f) + 33 -> (0x14c4e977ba1f5bac, 0x3d9635b15d59bab2) + 34 -> (0x109d8792fb4c4956, 0x97ab5e277de16228) + 35 -> (0x1a95a5b7f87a0ef0, 0xf2abc9d8c9689d0d) + 36 -> (0x154484932d2e725a, 0x5bbca17a3aba173e) + 37 -> (0x11039d428a8b8eae, 0xafca1ac82efb45cb) + 38 -> (0x1b38fb9daa78e44a, 0xb2dcf7a6b1920945) + 39 -> (0x15c72fb1552d836e, 0xf57d92ebc141a104) + 40 -> (0x116c262777579c58, 0xc46475896767b403) + 41 -> (0x1be03d0bf225c6f4, 0x6d6d88dbd8a5ecd2) + 42 -> (0x164cfda3281e38c3, 0x8abe071646eb23db) + 43 -> (0x11d7314f534b609c, 0x6efe6c11d255b649) + 44 -> (0x1c8b821885456760, 0xb197134fb6ef8a0e) + 45 -> (0x16d601ad376ab91a, 0x27ac0f72f8bfa1a5) + 46 -> (0x1244ce242c5560e1, 0xb95672c260994e1e) + 47 -> (0x1d3ae36d13bbce35, 0xf5571e03cdc21695) + 48 -> (0x17624f8a762fd82b, 0x2aac18030b01abab) + 49 -> (0x12b50c6ec4f31355, 0xbbbce0026f348956) + 50 -> (0x1dee7a4ad4b81eef, 0x92c7ccd0b1eda889) + 51 -> (0x17f1fb6f10934bf2, 0xdbd30a408e57ba07) + 52 -> (0x1327fc58da0f6ff5, 0x7ca8d50071dfc806) + 53 -> (0x1ea6608e29b24cbb, 0xfaa7bb33e9660cd6) + 54 -> (0x18851a0b548ea3c9, 0x9552fc298784d711) + 55 -> (0x139dae6f76d88307, 0xaaa8c9bad2d0ac0e) + 56 -> (0x1f62b0b257c0d1a5, 0xdddadc5e1e1aace3) + 57 -> (0x191bc08eac9a4151, 0x7e48b04b4b488a4f) + 58 -> (0x141633a556e1cdda, 0xcb6d59d5d5d3a1d9) + 59 -> (0x1011c2eaabe7d7e2, 0x3c577b1177dc817b) + 60 -> (0x19b604aaaca62636, 0xc6f25e825960cf2a) + 61 -> (0x14919d5556eb51c5, 0x6bf518684780a5bb) + 62 -> (0x10747ddddf22a7d1, 0x232a79ed06008496) + 63 -> (0x1a53fc9631d10c81, 0xd1dd8fe1a3340756) + 64 -> (0x150ffd44f4a73d34, 0xa7e4731ae8f66c45) + 65 -> (0x10d9976a5d52975d, 0x531d28e253f8569e) + 66 -> (0x1af5bf109550f22e, 0xeb61db03b98d5762) + 67 -> (0x159165a6ddda5b58, 0xbc4e48cfc7a445e8) + 68 -> (0x11411e1f17e1e2ad, 0x6371d3d96c836b20) + 69 -> (0x1b9b6364f3030448, 0x9f1c8628ad9f11cd) + 70 -> (0x1615e91d8f359d06, 0xe5b06b53be18db0b) + 71 -> (0x11ab20e472914a6b, 0xeaf3890fcb4715a2) + 72 -> (0x1c45016d841baa46, 0x44b8db4c7871bc37) + 73 -> (0x169d9abe03495505, 0x3c715d6c6c1635f) + 74 -> (0x1217aefe69077737, 0x3638de456bcde919) + 75 -> (0x1cf2b1970e725858, 0x56c163a2461641c1) + 76 -> (0x17288e1271f51379, 0xdf011c81d1ab67ce) + 77 -> (0x1286d80ec190dc61, 0x7f3416ce4155eca5) + 78 -> (0x1da48ce468e7c702, 0x6520247d3556476e) + 79 -> (0x17b6d71d20b96c01, 0xea801d30f7783925) + 80 -> (0x12f8ac174d612334, 0xbb99b0f3f92cfa84) + 81 -> (0x1e5aacf215683854, 0x5f5c4e532847f739) + 82 -> (0x18488a5b44536043, 0x7f7d0b75b9d32c2e) + 83 -> (0x136d3b7c36a919cf, 0x9930d5f7c7dc2358) + 84 -> (0x1f152bf9f10e8fb2, 0x8eb4898c72f9d226) + 85 -> (0x18ddbcc7f40ba628, 0x722a07a38f2e41b8) + 86 -> (0x13e497065cd61e86, 0xc1bb394fa5be9afa) + 87 -> (0x1fd424d6faf030d7, 0x9c5ec2190930f7f6) + 88 -> (0x197683df2f268d79, 0x49e56814075a5ff8) + 89 -> (0x145ecfe5bf520ac7, 0x6e51201005e1e660) + 90 -> (0x104bd984990e6f05, 0xf1da800cd181851a) + 91 -> (0x1a12f5a0f4e3e4d6, 0x4fc400148268d4f5) + 92 -> (0x14dbf7b3f71cb711, 0xd96999aa01ed772b) + 93 -> (0x10aff95cc5b09274, 0xadee1488018ac5bc) + 94 -> (0x1ab328946f80ea54, 0x497ceda668de092c) + 95 -> (0x155c2076bf9a5510, 0x3aca57b853e4d424) + 96 -> (0x1116805effaeaa73, 0x623b7960431d7683) + 97 -> (0x1b5733cb32b110b8, 0x9d2bf566d1c8bd9e) + 98 -> (0x15df5ca28ef40d60, 0x7dbcc452416d647f) + 99 -> (0x117f7d4ed8c33de6, 0xcafd69db678ab6cc) + 100 -> (0x1bff2ee48e052fd7, 0xab2f0fc572778adf) + 101 -> (0x1665bf1d3e6a8cac, 0x88f273045b92d580) + 102 -> (0x11eaff4a98553d56, 0xd3f528d049424466) + 103 -> (0x1cab3210f3bb9557, 0xb988414d4203a0a3) + 104 -> (0x16ef5b40c2fc7779, 0x6139cdd76802e6e9) + 105 -> (0x125915cd68c9f92d, 0xe761717920025254) + 106 -> (0x1d5b561574765b7c, 0xa568b58e999d5086) + 107 -> (0x177c44ddf6c515fd, 0x5120913ee14aa6d2) + 108 -> (0x12c9d0b1923744ca, 0xa74d40ff1aa21f0e) + 109 -> (0x1e0fb44f50586e11, 0xbaece64f769cb4a) + 110 -> (0x180c903f7379f1a7, 0x3c8bd850c5ee3c3b) + 111 -> (0x133d4032c2c7f485, 0xca0979da37f1c9c9) + 112 -> (0x1ec866b79e0cba6f, 0xa9a8c2f6bfe942db) + 113 -> (0x18a0522c7e709526, 0x2153cf2bccba9be3) + 114 -> (0x13b374f06526ddb8, 0x1aa9728970954982) + 115 -> (0x1f8587e7083e2f8c, 0xf775840f1a88759d) + 116 -> (0x19379fec0698260a, 0x5f9136727ba05e17) + 117 -> (0x142c7ff0054684d5, 0x1940f85b9619e4df) + 118 -> (0x1023998cd1053710, 0xe100c6afab47ea4c) + 119 -> (0x19d28f47b4d524e7, 0xce67a44c453fdd47) + 120 -> (0x14a8729fc3ddb71f, 0xd852e9d69dccb106) + 121 -> (0x1086c219697e2c19, 0x79dbee454b0a2738) + 122 -> (0x1a71368f0f30468f, 0x295fe3a211a9d859) + 123 -> (0x15275ed8d8f36ba5, 0xbab31c81a7bb137a) + 124 -> (0x10ec4be0ad8f8951, 0x6228e39aec95a92f) + 125 -> (0x1b13ac9aaf4c0ee8, 0x9d0e38f7e0ef7517) + 126 -> (0x15a956e225d67253, 0xb0d82d931a592a79) + 127 -> (0x11544581b7dec1dc, 0x8d79be0f4847552e) + 128 -> (0x1bba08cf8c979c94, 0x158f967eda0bbb7c) + 129 -> (0x162e6d72d6dfb076, 0x77a611ff14d62f97) + 130 -> (0x11bebdf578b2f391, 0xf951a7ff43de8c79) + 131 -> (0x1c6463225ab7ec1c, 0xc21c3ffed2fdad8e) + 132 -> (0x16b6b5b5155ff017, 0x1b0333242648ad8) + 133 -> (0x122bc490dde659ac, 0x159c28e9b83a246) + 134 -> (0x1d12d41afca3c2ac, 0xcef604175f3903a3) + 135 -> (0x17424348ca1c9bbd, 0x725e69ac4c2d9c83) + 136 -> (0x129b69070816e2fd, 0xf5185489d68ae39c) + 137 -> (0x1dc574d80cf16b2f, 0xee8d540fbdab05c6) + 138 -> (0x17d12a4670c1228c, 0xbed77672fe226b05) + 139 -> (0x130dbb6b8d674ed6, 0xff12c528cb4ebc04) + 140 -> (0x1e7c5f127bd87e24, 0xcb513b74787df9a0) + 141 -> (0x18637f41fcad31b7, 0x90dc929f9fe614d) + 142 -> (0x1382cc34ca2427c5, 0xa0d7d42194cb810a) + 143 -> (0x1f37ad21436d0c6f, 0x67bfb9cf5478ce77) + 144 -> (0x18f9574dcf8a7059, 0x1fcc94a5dd2d71f9) + 145 -> (0x13faac3e3fa1f37a, 0x7fd6dd517dbdf4c7) + 146 -> (0x1ff779fd329cb8c3, 0xffbe2ee8c92fee0b) + 147 -> (0x1992c7fdc216fa36, 0x6631bf20a0f324d6) + 148 -> (0x14756ccb01abfb5e, 0xb827cc1a1a5c1d78) + 149 -> (0x105df0a267bcc918, 0x935309ae7b7ce460) + 150 -> (0x1a2fe76a3f9474f4, 0x1eeb42b0c594a099) + 151 -> (0x14f31f8832dd2a5c, 0xe58902270476e6e1) + 152 -> (0x10c27fa028b0eeb0, 0xb7a0ce859d2bebe7) + 153 -> (0x1ad0cc33744e4ab4, 0x59014a6f61dfdfd8) + 154 -> (0x1573d68f903ea229, 0xe0cdd525e7e64cad) + 155 -> (0x11297872d9cbb4ee, 0x4d7177518651d6f1) + 156 -> (0x1b758d848fac54b0, 0x7be8bee8d6e957e8) + 157 -> (0x15f7a46a0c89dd59, 0xfcba3253df211320) + 158 -> (0x1192e9ee706e4aae, 0x63c8284318e74280) + 159 -> (0x1c1e43171a4a1117, 0x60d0d3827d86a66) + 160 -> (0x167e9c127b6e7412, 0x6b3da42cecad21eb) + 161 -> (0x11fee341fc585cdb, 0x88fe1cf0bd574e56) + 162 -> (0x1ccb0536608d615f, 0x419694b462254a23) + 163 -> (0x1708d0f84d3de77f, 0x67abaa29e81dd4e9) + 164 -> (0x126d73f9d764b932, 0xb95621bb2017dd87) + 165 -> (0x1d7becc2f23ac1ea, 0xc223692b668c95a5) + 166 -> (0x179657025b6234bb, 0xce82ba891ed6de1d) + 167 -> (0x12deac01e2b4f6fc, 0xa53562074bdf1818) + 168 -> (0x1e3113363787f194, 0x3b889cd87964f359) + 169 -> (0x18274291c6065adc, 0xfc6d4a46c783f5e1) + 170 -> (0x13529ba7d19eaf17, 0x30576e9f06032b1a) + 171 -> (0x1eea92a61c311825, 0x1a257dcb3cd1de90) + 172 -> (0x18bba884e35a79b7, 0x481dfe3c30a7e540) + 173 -> (0x13c9539d82aec7c5, 0xd34b31c9c0865100) + 174 -> (0x1fa885c8d117a609, 0x5211e942cda3b4cd) + 175 -> (0x19539e3a40dfb807, 0x74db21023e1c90a4) + 176 -> (0x1442e4fb67196005, 0xf715b401cb4a0d50) + 177 -> (0x103583fc527ab337, 0xf8de299b09080aa7) + 178 -> (0x19ef3993b72ab859, 0x8e304291a80cddd7) + 179 -> (0x14bf6142f8eef9e1, 0x3e8d020e200a4b13) + 180 -> (0x10991a9bfa58c7e7, 0x653d9b3e80083c0f) + 181 -> (0x1a8e90f9908e0ca5, 0x6ec8f864000d2ce4) + 182 -> (0x153eda614071a3b7, 0x8bd3f9e999a423ea) + 183 -> (0x10ff151a99f482f9, 0x3ca994bae1501cbb) + 184 -> (0x1b31bb5dc320d18e, 0xc775bac49bb3612b) + 185 -> (0x15c162b168e70e0b, 0xd2c4956a16291a89) + 186 -> (0x11678227871f3e6f, 0xdbd0778811ba7ba1) + 187 -> (0x1bd8d03f3e9863e6, 0x2c80bf401c5d929b) + 188 -> (0x16470cff6546b651, 0xbd33cc3349e47549) + 189 -> (0x11d270cc51055ea7, 0xca8fd68f6e505dd4) + 190 -> (0x1c83e7ad4e6efdd9, 0x4419574be3b3c953) + 191 -> (0x16cfec8aa52597e1, 0x347790982f63aa9) + 192 -> (0x123ff06eea847980, 0xcf6c60d468c4fbba) + 193 -> (0x1d331a4b10d3f59a, 0xe57a34870e07f92a) + 194 -> (0x175c1508da432ae2, 0x512e906c0b399422) + 195 -> (0x12b010d3e1cf5581, 0xda8ba6bcd5c7a9b5) + 196 -> (0x1de6815302e5559c, 0x90df712e22d90f87) + 197 -> (0x17eb9aa8cf1dde16, 0xda4c5a8b4f140c6c) + 198 -> (0x1322e220a5b17e78, 0xaea37ba2a5a9a38a) + 199 -> (0x1e9e369aa2b59727, 0x7dd25f6aa2a905a9) + 200 -> (0x187e92154ef7ac1f, 0x97db7f888220d154) + 201 -> (0x139874ddd8c6234c, 0x797c6606ce80a777) + 202 -> (0x1f5a549627a36bad, 0x8f2d700ae4010bf1) + 203 -> (0x191510781fb5efbe, 0xc2459a25000d65a) + 204 -> (0x1410d9f9b2f7f2fe, 0x701d1481d99a4515) + 205 -> (0x100d7b2e28c65bfe, 0xc017439b147b6a77) + 206 -> (0x19af2b7d0e0a2cca, 0xccf205c4ed9243f2) + 207 -> (0x148c22ca71a1bd6f, 0xa5b37d0be0e9cc2) + 208 -> (0x10701bd527b4978c, 0x848f973cb3ee3ce) + 209 -> (0x1a4cf9550c5425ac, 0xda0e5bec78649fb0) + 210 -> (0x150a6110d6a9b7bd, 0x7b3eaff060507fc0) + 211 -> (0x10d51a73deee2c97, 0x95cbbff380406633) + 212 -> (0x1aee90b964b04758, 0xefac665266cd7052) + 213 -> (0x158ba6fab6f36c47, 0x2623850eb8a459db) + 214 -> (0x113c85955f29236c, 0x1e82d0d893b6ae49) + 215 -> (0x1b9408eefea838ac, 0xfd9e1af41f8ab075) + 216 -> (0x16100725988693bd, 0x97b1af29b2d559f7) + 217 -> (0x11a66c1e139edc97, 0xac8e25baf5777b2c) + 218 -> (0x1c3d79c9b8fe2dbf, 0x7a7d092b2258c513) + 219 -> (0x169794a160cb57cc, 0x61fda0ef4ead6a76) + 220 -> (0x1212dd4de7091309, 0xe7fe1a590bbdeec5) + 221 -> (0x1ceafbafd80e84dc, 0xa6635d5b45fcb13a) + 222 -> (0x172262f3133ed0b0, 0x851c4aaf6b308dc8) + 223 -> (0x1281e8c275cbda26, 0xd0e36ef2bc26d7d4) + 224 -> (0x1d9ca79d894629d7, 0xb49f17eac6a48c86) + 225 -> (0x17b08617a104ee46, 0x2a18dfef0550706b) + 226 -> (0x12f39e794d9d8b6b, 0x54e0b3259dd9f389) + 227 -> (0x1e5297287c2f4578, 0x87cdeb6f62f65274) + 228 -> (0x18421286c9bf6ac6, 0xd30b22bf825ea85d) + 229 -> (0x13680ed23aff889f, 0xf3c1bcc684bb9e4) + 230 -> (0x1f0ce4839198da98, 0x18602c7a4079296d) + 231 -> (0x18d71d360e13e213, 0x46b356c833942124) + 232 -> (0x13df4a91a4dcb4dc, 0x388f78a029434db6) + 233 -> (0x1fcbaa82a1612160, 0x5a7f2766a86baf8a) + 234 -> (0x196fbb9bb44db44d, 0x153285ebb9efbfa2) + 235 -> (0x145962e2f6a4903d, 0xaa8ed189618c994e) + 236 -> (0x1047824f2bb6d9ca, 0xeed8a7a11ad6e10c) + 237 -> (0x1a0c03b1df8af611, 0x7e27729b5e249b45) + 238 -> (0x14d6695b193bf80d, 0xfe85f549181d4904) + 239 -> (0x10ab877c142ff9a4, 0xcb9e5dd4134aa0d0) + 240 -> (0x1aac0bf9b9e65c3a, 0xdf63c9535211014d) + 241 -> (0x15566ffafb1eb02f, 0x191ca10f74da6771) + 242 -> (0x1111f32f2f4bc025, 0xadb080d92a4852c1) + 243 -> (0x1b4feb7eb212cd09, 0x15e7348eaa0d5134) + 244 -> (0x15d98932280f0a6d, 0xab1f5d3eee710dc4) + 245 -> (0x117ad428200c0857, 0xbc1917658b8da49d) + 246 -> (0x1bf7b9d9cce00d59, 0x2cf4f23c127c3a94) + 247 -> (0x165fc7e170b33de0, 0xf0c3f4fcdb969543) + 248 -> (0x11e6398126f5cb1a, 0x5a365d9716121103) + 249 -> (0x1ca38f350b22de90, 0x9056fc24f01ce804) + 250 -> (0x16e93f5da2824ba6, 0xd9df301d8ce3ecd0) + 251 -> (0x125432b14ecea2eb, 0xe17f59b13d8323da) + 252 -> (0x1d53844ee47dd179, 0x68cbc2b52f38395c) + 253 -> (0x177603725064a794, 0x53d6355dbf602de3) + 254 -> (0x12c4cf8ea6b6ec76, 0xa9782ab165e68b1c) + 255 -> (0x1e07b27dd78b13f1, 0xf26aab56fd744fa) + 256 -> (0x18062864ac6f4327, 0x3f52222abfdf6a62) + 257 -> (0x1338205089f29c1f, 0x65db4e88997f884e) + 258 -> (0x1ec033b40fea9365, 0x6fc54a7428cc0d4a) + 259 -> (0x1899c2f673220f84, 0x596aa1f68709a43b) + 260 -> (0x13ae3591f5b4d936, 0xadeee7f86c07b696) + 261 -> (0x1f7d228322baf524, 0x497e3ff3e00c5756) + 262 -> (0x1930e868e89590e9, 0xd464fff64cd6ac45) + 263 -> (0x14272053ed4473ee, 0x4383fff83d7889d1) + 264 -> (0x101f4d0ff1038ff1, 0xcf9cccc69793a174) + 265 -> (0x19cbae7fe805b31c, 0x7f6147a425b90252) + 266 -> (0x14a2f1ffecd15c16, 0xcc4dd2e9b7c7350f) + 267 -> (0x10825b3323dab012, 0x3d0b0f215fd290d9) + 268 -> (0x1a6a2b85062ab350, 0x61ab4b689950e7c1) + 269 -> (0x1521bc6a6b555c40, 0x4e22a2ba1440b967) + 270 -> (0x10e7c9eebc4449cd, 0xb4ee894dd009453) + 271 -> (0x1b0c764ac6d3a948, 0x1217da87c800ed51) + 272 -> (0x15a391d56bdc876c, 0xdb46486ca000bdda) + 273 -> (0x114fa7ddefe39f8a, 0x490506bd4ccd64af) + 274 -> (0x1bb2a62fe638ff43, 0xa8080ac87ae23ab1) + 275 -> (0x162884f31e93ff69, 0x5339a239fbe82ef4) + 276 -> (0x11ba03f5b20fff87, 0x75c7b4fb2fecf25d) + 277 -> (0x1c5cd322b67fff3f, 0x22d92191e647ea2e) + 278 -> (0x16b0a8e891ffff65, 0xb57a8141850654f2) + 279 -> (0x1226ed86db3332b7, 0xc4620101373843f5) + 280 -> (0x1d0b15a491eb8459, 0x3a366801f1f39fee) + 281 -> (0x173c115074bc69e0, 0xfb5eb99b27f6198b) + 282 -> (0x129674405d6387e7, 0x2f7efae2865e7ad6) + 283 -> (0x1dbd86cd6238d971, 0xe597f7d0d6fd9156) + 284 -> (0x17cad23de82d7ac1, 0x8479930d78cadaab) + 285 -> (0x1308a831868ac89a, 0xd06142712d6f1556) + 286 -> (0x1e74404f3daada91, 0x4d686a4eaf182222) + 287 -> (0x185d003f6488aeda, 0xa453883ef279b4e8) + 288 -> (0x137d99cc506d58ae, 0xe9dc6cff28615d87) + 289 -> (0x1f2f5c7a1a488de4, 0xa960ae650d6895a4) + 290 -> (0x18f2b061aea07183, 0xbab3beb73ded4483) + _ -> (0x13f559e7bee6c136, 0x2ef6322c318a9d36) +#endif + +-- | Index into the 128-bit word lookup table double_pow5_split +get_double_pow5_split :: Int -> (Word64, Word64) +#if !PURE_HASKELL +get_double_pow5_split = getWord128At double_pow5_split +#else +-- > putStr $ case128 (fnorm double_pow5_bitcount) [0..double_max_split] +get_double_pow5_split i = case i of + 0 -> (0x1000000000000000, 0x0) + 1 -> (0x1400000000000000, 0x0) + 2 -> (0x1900000000000000, 0x0) + 3 -> (0x1f40000000000000, 0x0) + 4 -> (0x1388000000000000, 0x0) + 5 -> (0x186a000000000000, 0x0) + 6 -> (0x1e84800000000000, 0x0) + 7 -> (0x1312d00000000000, 0x0) + 8 -> (0x17d7840000000000, 0x0) + 9 -> (0x1dcd650000000000, 0x0) + 10 -> (0x12a05f2000000000, 0x0) + 11 -> (0x174876e800000000, 0x0) + 12 -> (0x1d1a94a200000000, 0x0) + 13 -> (0x12309ce540000000, 0x0) + 14 -> (0x16bcc41e90000000, 0x0) + 15 -> (0x1c6bf52634000000, 0x0) + 16 -> (0x11c37937e0800000, 0x0) + 17 -> (0x16345785d8a00000, 0x0) + 18 -> (0x1bc16d674ec80000, 0x0) + 19 -> (0x1158e460913d0000, 0x0) + 20 -> (0x15af1d78b58c4000, 0x0) + 21 -> (0x1b1ae4d6e2ef5000, 0x0) + 22 -> (0x10f0cf064dd59200, 0x0) + 23 -> (0x152d02c7e14af680, 0x0) + 24 -> (0x1a784379d99db420, 0x0) + 25 -> (0x108b2a2c28029094, 0x0) + 26 -> (0x14adf4b7320334b9, 0x0) + 27 -> (0x19d971e4fe8401e7, 0x4000000000000000) + 28 -> (0x1027e72f1f128130, 0x8800000000000000) + 29 -> (0x1431e0fae6d7217c, 0xaa00000000000000) + 30 -> (0x193e5939a08ce9db, 0xd480000000000000) + 31 -> (0x1f8def8808b02452, 0xc9a0000000000000) + 32 -> (0x13b8b5b5056e16b3, 0xbe04000000000000) + 33 -> (0x18a6e32246c99c60, 0xad85000000000000) + 34 -> (0x1ed09bead87c0378, 0xd8e6400000000000) + 35 -> (0x13426172c74d822b, 0x878fe80000000000) + 36 -> (0x1812f9cf7920e2b6, 0x6973e20000000000) + 37 -> (0x1e17b84357691b64, 0x3d0da8000000000) + 38 -> (0x12ced32a16a1b11e, 0x8262889000000000) + 39 -> (0x178287f49c4a1d66, 0x22fb2ab400000000) + 40 -> (0x1d6329f1c35ca4bf, 0xabb9f56100000000) + 41 -> (0x125dfa371a19e6f7, 0xcb54395ca0000000) + 42 -> (0x16f578c4e0a060b5, 0xbe2947b3c8000000) + 43 -> (0x1cb2d6f618c878e3, 0x2db399a0ba000000) + 44 -> (0x11efc659cf7d4b8d, 0xfc90400474400000) + 45 -> (0x166bb7f0435c9e71, 0x7bb4500591500000) + 46 -> (0x1c06a5ec5433c60d, 0xdaa16406f5a40000) + 47 -> (0x118427b3b4a05bc8, 0xa8a4de8459868000) + 48 -> (0x15e531a0a1c872ba, 0xd2ce16256fe82000) + 49 -> (0x1b5e7e08ca3a8f69, 0x87819baecbe22800) + 50 -> (0x111b0ec57e6499a1, 0xf4b1014d3f6d5900) + 51 -> (0x1561d276ddfdc00a, 0x71dd41a08f48af40) + 52 -> (0x1aba4714957d300d, 0xe549208b31adb10) + 53 -> (0x10b46c6cdd6e3e08, 0x28f4db456ff0c8ea) + 54 -> (0x14e1878814c9cd8a, 0x33321216cbecfb24) + 55 -> (0x1a19e96a19fc40ec, 0xbffe969c7ee839ed) + 56 -> (0x105031e2503da893, 0xf7ff1e21cf512434) + 57 -> (0x14643e5ae44d12b8, 0xf5fee5aa43256d41) + 58 -> (0x197d4df19d605767, 0x337e9f14d3eec892) + 59 -> (0x1fdca16e04b86d41, 0x5e46da08ea7ab6) + 60 -> (0x13e9e4e4c2f34448, 0xa03aec4845928cb2) + 61 -> (0x18e45e1df3b0155a, 0xc849a75a56f72fde) + 62 -> (0x1f1d75a5709c1ab1, 0x7a5c1130ecb4fbd6) + 63 -> (0x13726987666190ae, 0xec798abe93f11d65) + 64 -> (0x184f03e93ff9f4da, 0xa797ed6e38ed64bf) + 65 -> (0x1e62c4e38ff87211, 0x517de8c9c728bdef) + 66 -> (0x12fdbb0e39fb474a, 0xd2eeb17e1c7976b5) + 67 -> (0x17bd29d1c87a191d, 0x87aa5ddda397d462) + 68 -> (0x1dac74463a989f64, 0xe994f5550c7dc97b) + 69 -> (0x128bc8abe49f639f, 0x11fd195527ce9ded) + 70 -> (0x172ebad6ddc73c86, 0xd67c5faa71c24568) + 71 -> (0x1cfa698c95390ba8, 0x8c1b77950e32d6c2) + 72 -> (0x121c81f7dd43a749, 0x57912abd28dfc639) + 73 -> (0x16a3a275d494911b, 0xad75756c7317b7c8) + 74 -> (0x1c4c8b1349b9b562, 0x98d2d2c78fdda5ba) + 75 -> (0x11afd6ec0e14115d, 0x9f83c3bcb9ea8794) + 76 -> (0x161bcca7119915b5, 0x764b4abe8652979) + 77 -> (0x1ba2bfd0d5ff5b22, 0x493de1d6e27e73d7) + 78 -> (0x1145b7e285bf98f5, 0x6dc6ad264d8f0866) + 79 -> (0x159725db272f7f32, 0xc938586fe0f2ca80) + 80 -> (0x1afcef51f0fb5eff, 0x7b866e8bd92f7d20) + 81 -> (0x10de1593369d1b5f, 0xad34051767bdae34) + 82 -> (0x15159af804446237, 0x9881065d41ad19c1) + 83 -> (0x1a5b01b605557ac5, 0x7ea147f492186032) + 84 -> (0x1078e111c3556cbb, 0x6f24ccf8db4f3c1f) + 85 -> (0x14971956342ac7ea, 0x4aee003712230b27) + 86 -> (0x19bcdfabc13579e4, 0xdda98044d6abcdf0) + 87 -> (0x10160bcb58c16c2f, 0xa89f02b062b60b6) + 88 -> (0x141b8ebe2ef1c73a, 0xcd2c6c35c7b638e4) + 89 -> (0x1922726dbaae3909, 0x8077874339a3c71d) + 90 -> (0x1f6b0f092959c74b, 0xe0956914080cb8e4) + 91 -> (0x13a2e965b9d81c8f, 0x6c5d61ac8507f38e) + 92 -> (0x188ba3bf284e23b3, 0x4774ba17a649f072) + 93 -> (0x1eae8caef261aca0, 0x1951e89d8fdc6c8f) + 94 -> (0x132d17ed577d0be4, 0xfd3316279e9c3d9) + 95 -> (0x17f85de8ad5c4edd, 0x13c7fdbb186434cf) + 96 -> (0x1df67562d8b36294, 0x58b9fd29de7d4203) + 97 -> (0x12ba095dc7701d9c, 0xb7743e3a2b0e4942) + 98 -> (0x17688bb5394c2503, 0xe5514dc8b5d1db92) + 99 -> (0x1d42aea2879f2e44, 0xdea5a13ae3465277) + 100 -> (0x1249ad2594c37ceb, 0xb2784c4ce0bf38a) + 101 -> (0x16dc186ef9f45c25, 0xcdf165f6018ef06d) + 102 -> (0x1c931e8ab871732f, 0x416dbf7381f2ac88) + 103 -> (0x11dbf316b346e7fd, 0x88e497a83137abd5) + 104 -> (0x1652efdc6018a1fc, 0xeb1dbd923d8596ca) + 105 -> (0x1be7abd3781eca7c, 0x25e52cf6cce6fc7d) + 106 -> (0x1170cb642b133e8d, 0x97af3c1a40105dce) + 107 -> (0x15ccfe3d35d80e30, 0xfd9b0b20d0147542) + 108 -> (0x1b403dcc834e11bd, 0x3d01cde904199292) + 109 -> (0x1108269fd210cb16, 0x462120b1a28ffb9b) + 110 -> (0x154a3047c694fddb, 0xd7a968de0b33fa82) + 111 -> (0x1a9cbc59b83a3d52, 0xcd93c3158e00f923) + 112 -> (0x10a1f5b813246653, 0xc07c59ed78c09bb6) + 113 -> (0x14ca732617ed7fe8, 0xb09b7068d6f0c2a3) + 114 -> (0x19fd0fef9de8dfe2, 0xdcc24c830cacf34c) + 115 -> (0x103e29f5c2b18bed, 0xc9f96fd1e7ec180f) + 116 -> (0x144db473335deee9, 0x3c77cbc661e71e13) + 117 -> (0x1961219000356aa3, 0x8b95beb7fa60e598) + 118 -> (0x1fb969f40042c54c, 0x6e7b2e65f8f91efe) + 119 -> (0x13d3e2388029bb4f, 0xc50cfcffbb9bb35f) + 120 -> (0x18c8dac6a0342a23, 0xb6503c3faa82a037) + 121 -> (0x1efb1178484134ac, 0xa3e44b4f95234844) + 122 -> (0x135ceaeb2d28c0eb, 0xe66eaf11bd360d2b) + 123 -> (0x183425a5f872f126, 0xe00a5ad62c839075) + 124 -> (0x1e412f0f768fad70, 0x980cf18bb7a47493) + 125 -> (0x12e8bd69aa19cc66, 0x5f0816f752c6c8dc) + 126 -> (0x17a2ecc414a03f7f, 0xf6ca1cb527787b13) + 127 -> (0x1d8ba7f519c84f5f, 0xf47ca3e2715699d7) + 128 -> (0x127748f9301d319b, 0xf8cde66d86d62026) + 129 -> (0x17151b377c247e02, 0xf7016008e88ba830) + 130 -> (0x1cda62055b2d9d83, 0xb4c1b80b22ae923c) + 131 -> (0x12087d4358fc8272, 0x50f91306f5ad1b65) + 132 -> (0x168a9c942f3ba30e, 0xe53757c8b318623f) + 133 -> (0x1c2d43b93b0a8bd2, 0x9e852dbadfde7acf) + 134 -> (0x119c4a53c4e69763, 0xa3133c94cbeb0cc1) + 135 -> (0x16035ce8b6203d3c, 0x8bd80bb9fee5cff1) + 136 -> (0x1b843422e3a84c8b, 0xaece0ea87e9f43ee) + 137 -> (0x1132a095ce492fd7, 0x4d40c9294f238a75) + 138 -> (0x157f48bb41db7bcd, 0x2090fb73a2ec6d12) + 139 -> (0x1adf1aea12525ac0, 0x68b53a508ba78856) + 140 -> (0x10cb70d24b7378b8, 0x417144725748b536) + 141 -> (0x14fe4d06de5056e6, 0x51cd958eed1ae283) + 142 -> (0x1a3de04895e46c9f, 0xe640faf2a8619b24) + 143 -> (0x1066ac2d5daec3e3, 0xefe89cd7a93d00f7) + 144 -> (0x14805738b51a74dc, 0xebe2c40d938c4134) + 145 -> (0x19a06d06e2611214, 0x26db7510f86f5181) + 146 -> (0x100444244d7cab4c, 0x9849292a9b4592f1) + 147 -> (0x1405552d60dbd61f, 0xbe5b73754216f7ad) + 148 -> (0x1906aa78b912cba7, 0xadf25052929cb598) + 149 -> (0x1f485516e7577e91, 0x996ee4673743e2ff) + 150 -> (0x138d352e5096af1a, 0xffe54ec0828a6ddf) + 151 -> (0x18708279e4bc5ae1, 0xbfdea270a32d0957) + 152 -> (0x1e8ca3185deb719a, 0x2fd64b0ccbf84bad) + 153 -> (0x1317e5ef3ab32700, 0x5de5eee7ff7b2f4c) + 154 -> (0x17dddf6b095ff0c0, 0x755f6aa1ff59fb1f) + 155 -> (0x1dd55745cbb7ecf0, 0x92b7454a7f3079e7) + 156 -> (0x12a5568b9f52f416, 0x5bb28b4e8f7e4c30) + 157 -> (0x174eac2e8727b11b, 0xf29f2e22335ddf3c) + 158 -> (0x1d22573a28f19d62, 0xef46f9aac035570b) + 159 -> (0x123576845997025d, 0xd58c5c0ab8215667) + 160 -> (0x16c2d4256ffcc2f5, 0x4aef730d6629ac01) + 161 -> (0x1c73892ecbfbf3b2, 0x9dab4fd0bfb41701) + 162 -> (0x11c835bd3f7d784f, 0xa28b11e277d08e60) + 163 -> (0x163a432c8f5cd663, 0x8b2dd65b15c4b1f9) + 164 -> (0x1bc8d3f7b3340bfc, 0x6df94bf1db35de77) + 165 -> (0x115d847ad000877d, 0xc4bbcf772901ab0a) + 166 -> (0x15b4e5998400a95d, 0x35eac354f34215cd) + 167 -> (0x1b221effe500d3b4, 0x8365742a30129b40) + 168 -> (0x10f5535fef208450, 0xd21f689a5e0ba108) + 169 -> (0x1532a837eae8a565, 0x6a742c0f58e894a) + 170 -> (0x1a7f5245e5a2cebe, 0x4851137132f22b9d) + 171 -> (0x108f936baf85c136, 0xed32ac26bfd75b42) + 172 -> (0x14b378469b673184, 0xa87f57306fcd3212) + 173 -> (0x19e056584240fde5, 0xd29f2cfc8bc07e97) + 174 -> (0x102c35f729689eaf, 0xa3a37c1dd7584f1e) + 175 -> (0x14374374f3c2c65b, 0x8c8c5b254d2e62e6) + 176 -> (0x1945145230b377f2, 0x6faf71eea079fb9f) + 177 -> (0x1f965966bce055ef, 0xb9b4e6a48987a87) + 178 -> (0x13bdf7e0360c35b5, 0x674111026d5f4c94) + 179 -> (0x18ad75d8438f4322, 0xc111554308b71fba) + 180 -> (0x1ed8d34e547313eb, 0x7155aa93cae4e7a8) + 181 -> (0x13478410f4c7ec73, 0x26d58a9c5ecf10c9) + 182 -> (0x1819651531f9e78f, 0xf08aed437682d4fb) + 183 -> (0x1e1fbe5a7e786173, 0xecada89454238a3a) + 184 -> (0x12d3d6f88f0b3ce8, 0x73ec895cb4963664) + 185 -> (0x1788ccb6b2ce0c22, 0x90e7abb3e1bbc3fd) + 186 -> (0x1d6affe45f818f2b, 0x352196a0da2ab4fd) + 187 -> (0x1262dfeebbb0f97b, 0x134fe24885ab11e) + 188 -> (0x16fb97ea6a9d37d9, 0xc1823dadaa715d65) + 189 -> (0x1cba7de5054485d0, 0x31e2cd19150db4bf) + 190 -> (0x11f48eaf234ad3a2, 0x1f2dc02fad2890f7) + 191 -> (0x1671b25aec1d888a, 0xa6f9303b9872b535) + 192 -> (0x1c0e1ef1a724eaad, 0x50b77c4a7e8f6282) + 193 -> (0x1188d357087712ac, 0x5272adae8f199d91) + 194 -> (0x15eb082cca94d757, 0x670f591a32e004f6) + 195 -> (0x1b65ca37fd3a0d2d, 0x40d32f60bf980633) + 196 -> (0x111f9e62fe44483c, 0x4883fd9c77bf03e0) + 197 -> (0x156785fbbdd55a4b, 0x5aa4fd0395aec4d8) + 198 -> (0x1ac1677aad4ab0de, 0x314e3c447b1a760e) + 199 -> (0x10b8e0acac4eae8a, 0xded0e5aaccf089c9) + 200 -> (0x14e718d7d7625a2d, 0x96851f15802cac3b) + 201 -> (0x1a20df0dcd3af0b8, 0xfc2666dae037d74a) + 202 -> (0x10548b68a044d673, 0x9d980048cc22e68e) + 203 -> (0x1469ae42c8560c10, 0x84fe005aff2ba032) + 204 -> (0x198419d37a6b8f14, 0xa63d8071bef6883e) + 205 -> (0x1fe52048590672d9, 0xcfcce08e2eb42a4e) + 206 -> (0x13ef342d37a407c8, 0x21e00c58dd309a70) + 207 -> (0x18eb0138858d09ba, 0x2a580f6f147cc10d) + 208 -> (0x1f25c186a6f04c28, 0xb4ee134ad99bf150) + 209 -> (0x137798f428562f99, 0x7114cc0ec80176d2) + 210 -> (0x18557f31326bbb7f, 0xcd59ff127a01d486) + 211 -> (0x1e6adefd7f06aa5f, 0xc0b07ed7188249a8) + 212 -> (0x1302cb5e6f642a7b, 0xd86e4f466f516e09) + 213 -> (0x17c37e360b3d351a, 0xce89e3180b25c98b) + 214 -> (0x1db45dc38e0c8261, 0x822c5bde0def3bee) + 215 -> (0x1290ba9a38c7d17c, 0xf15bb96ac8b58575) + 216 -> (0x1734e940c6f9c5dc, 0x2db2a7c57ae2e6d2) + 217 -> (0x1d022390f8b83753, 0x391f51b6d99ba086) + 218 -> (0x1221563a9b732294, 0x3b3931248014454) + 219 -> (0x16a9abc9424feb39, 0x4a077d6da019569) + 220 -> (0x1c5416bb92e3e607, 0x45c895cc9081fac3) + 221 -> (0x11b48e353bce6fc4, 0x8b9d5d9fda513cba) + 222 -> (0x1621b1c28ac20bb5, 0xae84b507d0e58be8) + 223 -> (0x1baa1e332d728ea3, 0x1a25e249c51eeee3) + 224 -> (0x114a52dffc679925, 0xf057ad6e1b33554d) + 225 -> (0x159ce797fb817f6f, 0x6c6d98c9a2002aa1) + 226 -> (0x1b04217dfa61df4b, 0x4788fefc0a803549) + 227 -> (0x10e294eebc7d2b8f, 0xcb59f5d8690214e) + 228 -> (0x151b3a2a6b9c7672, 0xcfe30734e83429a1) + 229 -> (0x1a6208b50683940f, 0x83dbc9022241340a) + 230 -> (0x107d457124123c89, 0xb2695da15568c086) + 231 -> (0x149c96cd6d16cbac, 0x1f03b509aac2f0a7) + 232 -> (0x19c3bc80c85c7e97, 0x26c4a24c1573acd1) + 233 -> (0x101a55d07d39cf1e, 0x783ae56f8d684c03) + 234 -> (0x1420eb449c8842e6, 0x16499ecb70c25f03) + 235 -> (0x19292615c3aa539f, 0x9bdc067e4cf2f6c4) + 236 -> (0x1f736f9b3494e887, 0x82d3081de02fb476) + 237 -> (0x13a825c100dd1154, 0xb1c3e512ac1dd0c9) + 238 -> (0x18922f31411455a9, 0xde34de57572544fc) + 239 -> (0x1eb6bafd91596b14, 0x55c215ed2cee963b) + 240 -> (0x133234de7ad7e2ec, 0xb5994db43c151de5) + 241 -> (0x17fec216198ddba7, 0xe2ffa1214b1a655e) + 242 -> (0x1dfe729b9ff15291, 0xdbbf89699de0feb6) + 243 -> (0x12bf07a143f6d39b, 0x2957b5e202ac9f31) + 244 -> (0x176ec98994f48881, 0xf3ada35a8357c6fe) + 245 -> (0x1d4a7bebfa31aaa2, 0x70990c31242db8bd) + 246 -> (0x124e8d737c5f0aa5, 0x865fa79eb69c9376) + 247 -> (0x16e230d05b76cd4e, 0xe7f791866443b854) + 248 -> (0x1c9abd04725480a2, 0xa1f575e7fd54a669) + 249 -> (0x11e0b622c774d065, 0xa53969b0fe54e801) + 250 -> (0x1658e3ab7952047f, 0xe87c41d3dea2202) + 251 -> (0x1bef1c9657a6859e, 0xd229b5248d64aa82) + 252 -> (0x117571ddf6c81383, 0x435a1136d85eea91) + 253 -> (0x15d2ce55747a1864, 0x143095848e76a536) + 254 -> (0x1b4781ead1989e7d, 0x193cbae5b2144e83) + 255 -> (0x110cb132c2ff630e, 0x2fc5f4cf8f4cb112) + 256 -> (0x154fdd7f73bf3bd1, 0xbbb77203731fdd56) + 257 -> (0x1aa3d4df50af0ac6, 0x2aa54e844fe7d4ac) + 258 -> (0x10a6650b926d66bb, 0xdaa75112b1f0e4eb) + 259 -> (0x14cffe4e7708c06a, 0xd15125575e6d1e26) + 260 -> (0x1a03fde214caf085, 0x85a56ead360865b0) + 261 -> (0x10427ead4cfed653, 0x7387652c41c53f8e) + 262 -> (0x14531e58a03e8be8, 0x50693e7752368f71) + 263 -> (0x1967e5eec84e2ee2, 0x64838e1526c4334e) + 264 -> (0x1fc1df6a7a61ba9a, 0xfda4719a70754022) + 265 -> (0x13d92ba28c7d14a0, 0xde86c70086494815) + 266 -> (0x18cf768b2f9c59c9, 0x162878c0a7db9a1a) + 267 -> (0x1f03542dfb83703b, 0x5bb296f0d1d280a1) + 268 -> (0x1362149cbd322625, 0x194f9e5683239064) + 269 -> (0x183a99c3ec7eafae, 0x5fa385ec23ec747e) + 270 -> (0x1e494034e79e5b99, 0xf78c67672ce7919d) + 271 -> (0x12edc82110c2f940, 0x3ab7c0a07c10bb02) + 272 -> (0x17a93a2954f3b790, 0x4965b0c89b14e9c3) + 273 -> (0x1d9388b3aa30a574, 0x5bbf1cfac1da2433) + 274 -> (0x127c35704a5e6768, 0xb957721cb92856a0) + 275 -> (0x171b42cc5cf60142, 0xe7ad4ea3e7726c48) + 276 -> (0x1ce2137f74338193, 0xa198a24ce14f075a) + 277 -> (0x120d4c2fa8a030fc, 0x44ff65700cd16498) + 278 -> (0x16909f3b92c83d3b, 0x563f3ecc1005bdbe) + 279 -> (0x1c34c70a777a4c8a, 0x2bcf0e7f14072d2e) + 280 -> (0x11a0fc668aac6fd6, 0x5b61690f6c847c3d) + 281 -> (0x16093b802d578bcb, 0xf239c35347a59b4c) + 282 -> (0x1b8b8a6038ad6ebe, 0xeec83428198f021f) + 283 -> (0x1137367c236c6537, 0x553d20990ff96153) + 284 -> (0x1585041b2c477e85, 0x2a8c68bf53f7b9a8) + 285 -> (0x1ae64521f7595e26, 0x752f82ef28f5a812) + 286 -> (0x10cfeb353a97dad8, 0x93db1d57999890b) + 287 -> (0x1503e602893dd18e, 0xb8d1e4ad7ffeb4e) + 288 -> (0x1a44df832b8d45f1, 0x8e7065dd8dffe622) + 289 -> (0x106b0bb1fb384bb6, 0xf9063faa78bfefd5) + 290 -> (0x1485ce9e7a065ea4, 0xb747cf9516efebca) + 291 -> (0x19a742461887f64d, 0xe519c37a5cabe6bd) + 292 -> (0x1008896bcf54f9f0, 0xaf301a2c79eb7036) + 293 -> (0x140aabc6c32a386c, 0xdafc20b798664c43) + 294 -> (0x190d56b873f4c688, 0x11bb28e57e7fdf54) + 295 -> (0x1f50ac6690f1f82a, 0x1629f31ede1fd72a) + 296 -> (0x13926bc01a973b1a, 0x4dda37f34ad3e67a) + 297 -> (0x187706b0213d09e0, 0xe150c5f01d88e019) + 298 -> (0x1e94c85c298c4c59, 0x19a4f76c24eb181f) + 299 -> (0x131cfd3999f7afb7, 0xb0071aa39712ef13) + 300 -> (0x17e43c8800759ba5, 0x9c08e14c7cd7aad8) + 301 -> (0x1ddd4baa0093028f, 0x30b199f9c0d958e) + 302 -> (0x12aa4f4a405be199, 0x61e6f003c1887d79) + 303 -> (0x1754e31cd072d9ff, 0xba60ac04b1ea9cd7) + 304 -> (0x1d2a1be4048f907f, 0xa8f8d705de65440d) + 305 -> (0x123a516e82d9ba4f, 0xc99b8663aaff4a88) + 306 -> (0x16c8e5ca239028e3, 0xbc0267fc95bf1d2a) + 307 -> (0x1c7b1f3cac74331c, 0xab0301fbbb2ee474) + 308 -> (0x11ccf385ebc89ff1, 0xeae1e13d54fd4ec9) + 309 -> (0x1640306766bac7ee, 0x659a598caa3ca27b) + 310 -> (0x1bd03c81406979e9, 0xff00efefd4cbcb1a) + 311 -> (0x116225d0c841ec32, 0x3f6095f5e4ff5ef0) + 312 -> (0x15baaf44fa52673e, 0xcf38bb735e3f36ac) + 313 -> (0x1b295b1638e7010e, 0x8306ea5035cf0457) + 314 -> (0x10f9d8ede39060a9, 0x11e4527221a162b6) + 315 -> (0x15384f295c7478d3, 0x565d670eaa09bb64) + 316 -> (0x1a8662f3b3919708, 0x2bf4c0d2548c2a3d) + 317 -> (0x1093fdd8503afe65, 0x1b78f88374d79a66) + 318 -> (0x14b8fd4e6449bdfe, 0x625736a4520d8100) + 319 -> (0x19e73ca1fd5c2d7d, 0xfaed044d6690e140) + 320 -> (0x103085e53e599c6e, 0xbcd422b0601a8cc8) + 321 -> (0x143ca75e8df0038a, 0x6c092b5c78212ffa) + 322 -> (0x194bd136316c046d, 0x70b763396297bf8) + 323 -> (0x1f9ec583bdc70588, 0x48ce53c07bb3daf6) + 324 -> (0x13c33b72569c6375, 0x2d80f4584d5068da) + _ -> (0x18b40a4eec437c52, 0x78e1316e60a48310) +#endif + +-- | Take the high bits of m * 5^-e2-q / 2^k / 2^q-k +mulPow5DivPow2 :: Word64 -> Int -> Int -> Word64 +mulPow5DivPow2 m i j = mulShift64 m (get_double_pow5_split i) j + +-- | Take the high bits of m * 2^k / 5^q / 2^-e2+q+k +mulPow5InvDivPow2 :: Word64 -> Int -> Int -> Word64 +mulPow5InvDivPow2 m q j = mulShift64 m (get_double_pow5_inv_split q) j + +-- | Handle case e2 >= 0 +d2dGT :: Int32 -> Word64 -> Word64 -> Word64 -> (BoundsState Word64, Int32) +d2dGT e2' u v w = + let e2 = int32ToInt e2' + q = log10pow2 e2 - fromEnum (e2 > 3) + -- k = B0 + log_2(5^q) + k = double_pow5_inv_bitcount + pow5bits q - 1 + i = -e2 + q + k + -- (u, v, w) * 2^k / 5^q / 2^-e2+q+k + u' = mulPow5InvDivPow2 u q i + v' = mulPow5InvDivPow2 v q i + w' = mulPow5InvDivPow2 w q i + !(vvTrailing, vuTrailing, vw') = + case () of + _ | q <= 21 && (drem5 v == 0) + -> (multipleOfPowerOf5 v q, False, w') + | q <= 21 && acceptBounds v + -> (False, multipleOfPowerOf5 u q, w') + | q <= 21 + -> (False, False, w' - boolToWord64 (multipleOfPowerOf5 w q)) + | otherwise + -> (False, False, w') + in (BoundsState u' v' vw' 0 vuTrailing vvTrailing, intToInt32 q) + +-- | Handle case e2 < 0 +d2dLT :: Int32 -> Word64 -> Word64 -> Word64 -> (BoundsState Word64, Int32) +d2dLT e2' u v w = + let e2 = int32ToInt e2' + q = log10pow5 (-e2) - fromEnum (-e2 > 1) + e10 = q + e2 + i = -e2 - q + -- k = log_2(5^-e2-q) - B1 + k = pow5bits i - double_pow5_bitcount + j = q - k + -- (u, v, w) * 5^-e2-q / 2^k / 2^q-k + u' = mulPow5DivPow2 u i j + v' = mulPow5DivPow2 v i j + w' = mulPow5DivPow2 w i j + !(vvTrailing, vuTrailing, vw') = + case () of + _ | q <= 1 && acceptBounds v + -> (True, v - u == 2, w') -- mmShift == 1 + | q <= 1 + -> (True, False, w' - 1) + | q < 63 + -> (multipleOfPowerOf2 v (q - 1), False, w') + | otherwise + -> (False, False, w') + in (BoundsState u' v' vw' 0 vuTrailing vvTrailing, intToInt32 e10) + +-- | Returns the decimal representation of the given mantissa and exponent of a +-- 64-bit Double using the ryu algorithm. +d2d :: Word64 -> Word64 -> FloatingDecimal +d2d m e = + let !mf = if e == 0 + then m + else (1 `unsafeShiftL` double_mantissa_bits) .|. m + !ef = intToInt32 $ if e == 0 + then 1 - (double_bias + double_mantissa_bits) + else word64ToInt e - (double_bias + double_mantissa_bits) + !e2 = ef - 2 + -- Step 2. 3-tuple (u, v, w) * 2**e2 + !u = 4 * mf - 1 - boolToWord64 (m /= 0 || e <= 1) + !v = 4 * mf + !w = 4 * mf + 2 + -- Step 3. convert to decimal power base + !(state, e10) = + if e2 >= 0 + then d2dGT e2 u v w + else d2dLT e2 u v w + -- Step 4: Find the shortest decimal representation in the interval of + -- valid representations. + !(output, removed) = + let rounded = closestCorrectlyRounded (acceptBounds v) + in first rounded $ if vvIsTrailingZeros state || vuIsTrailingZeros state + then trimTrailing state + else trimNoTrailing state + !e' = e10 + removed + in FloatingDecimal output e' + +-- | Split a Double into (sign, mantissa, exponent) +breakdown :: Double -> (Bool, Word64, Word64) +breakdown f = + let bits = castDoubleToWord64 f + sign = ((bits `unsafeShiftR` (double_mantissa_bits + double_exponent_bits)) .&. 1) /= 0 + mantissa = bits .&. mask double_mantissa_bits + expo = (bits `unsafeShiftR` double_mantissa_bits) .&. mask double_exponent_bits + in (sign, mantissa, expo) + +-- | Dispatches to `d2d` or `d2dSmallInt` and applies the given formatters +{-# INLINE d2s' #-} +d2s' :: (Bool -> Word64 -> Int32 -> a) -> (NonNumbersAndZero -> a) -> Double -> a +d2s' formatter specialFormatter d = + let (sign, mantissa, expo) = breakdown d + in if (expo == mask double_exponent_bits) || (expo == 0 && mantissa == 0) + then specialFormatter NonNumbersAndZero + { negative=sign + , exponent_all_one=expo > 0 + , mantissa_non_zero=mantissa > 0 } + else let v = unifySmallTrailing <$> d2dSmallInt mantissa expo + FloatingDecimal m e = fromMaybe (d2d mantissa expo) v + in formatter sign m e + +-- | Render a Double in scientific notation +d2s :: Double -> Builder +d2s d = primBounded (d2s' toCharsScientific toCharsNonNumbersAndZero d) () + +-- | Returns the decimal representation of a Double. NaN and Infinity will +-- return `FloatingDecimal 0 0` +d2Intermediate :: Double -> FloatingDecimal +d2Intermediate = d2s' (const FloatingDecimal) (const $ FloatingDecimal 0 0) diff --git a/Data/ByteString/Builder/RealFloat/F2S.hs b/Data/ByteString/Builder/RealFloat/F2S.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/RealFloat/F2S.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Data.ByteString.Builder.RealFloat.F2S +-- Copyright : (c) Lawrence Wu 2021 +-- License : BSD-style +-- Maintainer : lawrencejwu@gmail.com +-- +-- Implementation of float-to-string conversion + +module Data.ByteString.Builder.RealFloat.F2S + ( FloatingDecimal(..) + , f2s + , f2Intermediate + ) where + +import Control.Arrow (first) +import Data.Bits ((.|.), (.&.), unsafeShiftL, unsafeShiftR) +import Data.ByteString.Builder.Internal (Builder) +import Data.ByteString.Builder.Prim (primBounded) +import Data.ByteString.Builder.RealFloat.Internal +import GHC.Int (Int32(..)) +import GHC.Word (Word32(..), Word64(..)) + +#if !PURE_HASKELL +import GHC.Ptr (Ptr(..)) +#endif + +-- See Data.ByteString.Builder.RealFloat.TableGenerator for a high-level +-- explanation of the ryu algorithm + +#if !PURE_HASKELL +-- | Table of 2^k / 5^q + 1 +-- +-- > fmap (finv float_pow5_inv_bitcount) [0..float_max_inv_split] +foreign import ccall "&hs_bytestring_float_pow5_inv_split" + float_pow5_inv_split :: Ptr Word64 + +-- | Table of 5^(-e2-q) / 2^k + 1 +-- +-- > fmap (fnorm float_pow5_bitcount) [0..float_max_split] +foreign import ccall "&hs_bytestring_float_pow5_split" + float_pow5_split :: Ptr Word64 +#endif + +-- | Number of mantissa bits of a 32-bit float. The number of significant bits +-- (floatDigits (undefined :: Float)) is 24 since we have a leading 1 for +-- normal floats and 0 for subnormal floats +float_mantissa_bits :: Int +float_mantissa_bits = 23 + +-- | Number of exponent bits of a 32-bit float +float_exponent_bits :: Int +float_exponent_bits = 8 + +-- | Bias in encoded 32-bit float representation (2^7 - 1) +float_bias :: Int +float_bias = 127 + +data FloatingDecimal = FloatingDecimal + { fmantissa :: !Word32 + , fexponent :: !Int32 + } deriving (Show, Eq) + +-- | Multiply a 32-bit number with a 64-bit number while keeping the upper 64 +-- bits. Then shift by specified amount minus 32 +mulShift32 :: Word32 -> Word64 -> Int -> Word32 +mulShift32 m factor shift = + let factorLo = factor .&. mask 32 + factorHi = factor `unsafeShiftR` 32 + bits0 = word32ToWord64 m * factorLo + bits1 = word32ToWord64 m * factorHi + total = (bits0 `unsafeShiftR` 32) + bits1 + in word64ToWord32 $ total `unsafeShiftR` (shift - 32) + +-- | Index into the 64-bit word lookup table float_pow5_inv_split +get_float_pow5_inv_split :: Int -> Word64 +#if !PURE_HASKELL +get_float_pow5_inv_split = getWord64At float_pow5_inv_split +#else +-- > putStr $ case64 (finv float_pow5_inv_bitcount) [0..float_max_inv_split] +get_float_pow5_inv_split i = case i of + 0 -> 0x800000000000001 + 1 -> 0x666666666666667 + 2 -> 0x51eb851eb851eb9 + 3 -> 0x4189374bc6a7efa + 4 -> 0x68db8bac710cb2a + 5 -> 0x53e2d6238da3c22 + 6 -> 0x431bde82d7b634e + 7 -> 0x6b5fca6af2bd216 + 8 -> 0x55e63b88c230e78 + 9 -> 0x44b82fa09b5a52d + 10 -> 0x6df37f675ef6eae + 11 -> 0x57f5ff85e592558 + 12 -> 0x465e6604b7a8447 + 13 -> 0x709709a125da071 + 14 -> 0x5a126e1a84ae6c1 + 15 -> 0x480ebe7b9d58567 + 16 -> 0x734aca5f6226f0b + 17 -> 0x5c3bd5191b525a3 + 18 -> 0x49c97747490eae9 + 19 -> 0x760f253edb4ab0e + 20 -> 0x5e72843249088d8 + 21 -> 0x4b8ed0283a6d3e0 + 22 -> 0x78e480405d7b966 + 23 -> 0x60b6cd004ac9452 + 24 -> 0x4d5f0a66a23a9db + 25 -> 0x7bcb43d769f762b + 26 -> 0x63090312bb2c4ef + 27 -> 0x4f3a68dbc8f03f3 + 28 -> 0x7ec3daf94180651 + 29 -> 0x65697bfa9acd1da + _ -> 0x51212ffbaf0a7e2 +#endif + +-- | Index into the 64-bit word lookup table float_pow5_split +get_float_pow5_split :: Int -> Word64 +#if !PURE_HASKELL +get_float_pow5_split = getWord64At float_pow5_split +#else +-- > putStr $ case64 (fnorm float_pow5_bitcount) [0..float_max_split] +get_float_pow5_split i = case i of + 0 -> 0x1000000000000000 + 1 -> 0x1400000000000000 + 2 -> 0x1900000000000000 + 3 -> 0x1f40000000000000 + 4 -> 0x1388000000000000 + 5 -> 0x186a000000000000 + 6 -> 0x1e84800000000000 + 7 -> 0x1312d00000000000 + 8 -> 0x17d7840000000000 + 9 -> 0x1dcd650000000000 + 10 -> 0x12a05f2000000000 + 11 -> 0x174876e800000000 + 12 -> 0x1d1a94a200000000 + 13 -> 0x12309ce540000000 + 14 -> 0x16bcc41e90000000 + 15 -> 0x1c6bf52634000000 + 16 -> 0x11c37937e0800000 + 17 -> 0x16345785d8a00000 + 18 -> 0x1bc16d674ec80000 + 19 -> 0x1158e460913d0000 + 20 -> 0x15af1d78b58c4000 + 21 -> 0x1b1ae4d6e2ef5000 + 22 -> 0x10f0cf064dd59200 + 23 -> 0x152d02c7e14af680 + 24 -> 0x1a784379d99db420 + 25 -> 0x108b2a2c28029094 + 26 -> 0x14adf4b7320334b9 + 27 -> 0x19d971e4fe8401e7 + 28 -> 0x1027e72f1f128130 + 29 -> 0x1431e0fae6d7217c + 30 -> 0x193e5939a08ce9db + 31 -> 0x1f8def8808b02452 + 32 -> 0x13b8b5b5056e16b3 + 33 -> 0x18a6e32246c99c60 + 34 -> 0x1ed09bead87c0378 + 35 -> 0x13426172c74d822b + 36 -> 0x1812f9cf7920e2b6 + 37 -> 0x1e17b84357691b64 + 38 -> 0x12ced32a16a1b11e + 39 -> 0x178287f49c4a1d66 + 40 -> 0x1d6329f1c35ca4bf + 41 -> 0x125dfa371a19e6f7 + 42 -> 0x16f578c4e0a060b5 + 43 -> 0x1cb2d6f618c878e3 + 44 -> 0x11efc659cf7d4b8d + 45 -> 0x166bb7f0435c9e71 + _ -> 0x1c06a5ec5433c60d +#endif + +-- | Take the high bits of m * 2^k / 5^q / 2^-e2+q+k +mulPow5InvDivPow2 :: Word32 -> Int -> Int -> Word32 +mulPow5InvDivPow2 m q j = mulShift32 m (get_float_pow5_inv_split q) j + +-- | Take the high bits of m * 5^-e2-q / 2^k / 2^q-k +mulPow5DivPow2 :: Word32 -> Int -> Int -> Word32 +mulPow5DivPow2 m i j = mulShift32 m (get_float_pow5_split i) j + +-- | Handle case e2 >= 0 +f2dGT :: Int32 -> Word32 -> Word32 -> Word32 -> (BoundsState Word32, Int32) +f2dGT e2' u v w = + let e2 = int32ToInt e2' + -- q = e10 = log_10(2^e2) + q = log10pow2 e2 + -- k = B0 + log_2(5^q) + k = float_pow5_inv_bitcount + pow5bits q - 1 + i = -e2 + q + k + -- (u, v, w) * 2^k / 5^q / 2^-e2+q+k + u' = mulPow5InvDivPow2 u q i + v' = mulPow5InvDivPow2 v q i + w' = mulPow5InvDivPow2 w q i + !lastRemoved = + if q /= 0 && fquot10 (w' - 1) <= fquot10 u' + -- We need to know one removed digit even if we are not going to loop + -- below. We could use q = X - 1 above, except that would require 33 + -- bits for the result, and we've found that 32-bit arithmetic is + -- faster even on 64-bit machines. + then let l = float_pow5_inv_bitcount + pow5bits (q - 1) - 1 + in frem10 (mulPow5InvDivPow2 v (q - 1) (-e2 + q - 1 + l)) + else 0 + !(vvTrailing, vuTrailing, vw') = + case () of + _ | q < 9 && frem5 v == 0 + -> (multipleOfPowerOf5 v q, False, w') + | q < 9 && acceptBounds v + -> (False, multipleOfPowerOf5 u q, w') + | q < 9 + -> (False, False, w' - boolToWord32 (multipleOfPowerOf5 w q)) + | otherwise + -> (False, False, w') + in (BoundsState u' v' vw' lastRemoved vuTrailing vvTrailing, intToInt32 q) + +-- | Handle case e2 < 0 +f2dLT :: Int32 -> Word32 -> Word32 -> Word32 -> (BoundsState Word32, Int32) +f2dLT e2' u v w = + let e2 = int32ToInt e2' + q = log10pow5 (-e2) + e10 = q + e2 + i = (-e2) - q + -- k = log_2(5^-e2-q) - B1 + k = pow5bits i - float_pow5_bitcount + j = q - k + -- (u, v, w) * 5^-e2-q / 2^k / 2^q-k + u' = mulPow5DivPow2 u i j + v' = mulPow5DivPow2 v i j + w' = mulPow5DivPow2 w i j + !lastRemoved = + if q /= 0 && fquot10 (w' - 1) <= fquot10 u' + then let j' = q - 1 - (pow5bits (i + 1) - float_pow5_bitcount) + in frem10 (mulPow5DivPow2 v (i + 1) j') + else 0 + !(vvTrailing , vuTrailing, vw') = + case () of + _ | q <= 1 && acceptBounds v + -> (True, v - u == 2, w') -- mmShift == 1 + | q <= 1 + -> (True, False, w' - 1) + | q < 31 + -> (multipleOfPowerOf2 v (q - 1), False, w') + | otherwise + -> (False, False, w') + in (BoundsState u' v' vw' lastRemoved vuTrailing vvTrailing, intToInt32 e10) + +-- | Returns the decimal representation of the given mantissa and exponent of a +-- 32-bit Float using the ryu algorithm. +f2d :: Word32 -> Word32 -> FloatingDecimal +f2d m e = + let !mf = if e == 0 + then m + else (1 `unsafeShiftL` float_mantissa_bits) .|. m + !ef = intToInt32 $ if e == 0 + then 1 - (float_bias + float_mantissa_bits) + else word32ToInt e - (float_bias + float_mantissa_bits) + !e2 = ef - 2 + -- Step 2. 3-tuple (u, v, w) * 2**e2 + !u = 4 * mf - 1 - boolToWord32 (m /= 0 || e <= 1) + !v = 4 * mf + !w = 4 * mf + 2 + -- Step 3. convert to decimal power base + !(state, e10) = + if e2 >= 0 + then f2dGT e2 u v w + else f2dLT e2 u v w + -- Step 4: Find the shortest decimal representation in the interval of + -- valid representations. + !(output, removed) = + let rounded = closestCorrectlyRounded (acceptBounds v) + in first rounded $ if vvIsTrailingZeros state || vuIsTrailingZeros state + then trimTrailing state + else trimNoTrailing state + !e' = e10 + removed + in FloatingDecimal output e' + +-- | Split a Float into (sign, mantissa, exponent) +breakdown :: Float -> (Bool, Word32, Word32) +breakdown f = + let bits = castFloatToWord32 f + sign = ((bits `unsafeShiftR` (float_mantissa_bits + float_exponent_bits)) .&. 1) /= 0 + mantissa = bits .&. mask float_mantissa_bits + expo = (bits `unsafeShiftR` float_mantissa_bits) .&. mask float_exponent_bits + in (sign, mantissa, expo) + +-- | Dispatches to `f2d` and applies the given formatters +{-# INLINE f2s' #-} +f2s' :: (Bool -> Word32 -> Int32 -> a) -> (NonNumbersAndZero -> a) -> Float -> a +f2s' formatter specialFormatter f = + let (sign, mantissa, expo) = breakdown f + in if (expo == mask float_exponent_bits) || (expo == 0 && mantissa == 0) + then specialFormatter NonNumbersAndZero + { negative=sign + , exponent_all_one=expo > 0 + , mantissa_non_zero=mantissa > 0 } + else let FloatingDecimal m e = f2d mantissa expo + in formatter sign m e + +-- | Render a Float in scientific notation +f2s :: Float -> Builder +f2s f = primBounded (f2s' toCharsScientific toCharsNonNumbersAndZero f) () + +-- | Returns the decimal representation of a Float. NaN and Infinity will +-- return `FloatingDecimal 0 0` +f2Intermediate :: Float -> FloatingDecimal +f2Intermediate = f2s' (const FloatingDecimal) (const $ FloatingDecimal 0 0) diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -0,0 +1,864 @@ +{-# LANGUAGE CPP #-} + +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Data.ByteString.Builder.RealFloat.Internal +-- Copyright : (c) Lawrence Wu 2021 +-- License : BSD-style +-- Maintainer : lawrencejwu@gmail.com +-- +-- Various floating-to-string conversion helpers that are somewhat +-- floating-size agnostic +-- +-- This module includes +-- +-- - Efficient formatting for scientific floating-to-string +-- - Trailing zero handling when converting to decimal power base +-- - Approximations for logarithms of powers +-- - Fast-division by reciprocal multiplication +-- - Prim-op bit-wise peek + +module Data.ByteString.Builder.RealFloat.Internal + ( mask + , NonNumbersAndZero(..) + , toCharsNonNumbersAndZero + , decimalLength9 + , decimalLength17 + , Mantissa + , pow5bits + , log10pow2 + , log10pow5 + , pow5_factor + , multipleOfPowerOf5 + , multipleOfPowerOf2 + , acceptBounds + , BoundsState(..) + , trimTrailing + , trimNoTrailing + , closestCorrectlyRounded + , toCharsScientific + -- hand-rolled division and remainder for f2s and d2s + , fquot10 + , frem10 + , fquot5 + , frem5 + , dquot10 + , dquotRem10 + , dquot5 + , drem5 + , dquot100 + -- prim-op helpers + , timesWord2 + , castDoubleToWord64 + , castFloatToWord32 + , getWord64At + , getWord128At + -- monomorphic conversions + , boolToWord32 + , boolToWord64 + , int32ToInt + , intToInt32 + , word32ToInt + , word64ToInt + , word32ToWord64 + , word64ToWord32 + + , module Data.ByteString.Builder.RealFloat.TableGenerator + ) where + +import Control.Monad (foldM) +import Data.Bits (Bits(..), FiniteBits(..)) +import Data.ByteString.Internal (c2w) +import Data.ByteString.Builder.Prim.Internal (BoundedPrim, boundedPrim) +import Data.ByteString.Builder.RealFloat.TableGenerator +import Data.ByteString.Utils.ByteOrder +import Data.ByteString.Utils.UnalignedAccess +#if PURE_HASKELL +import qualified Data.ByteString.Internal.Pure as Pure +#else +import Foreign.C.Types +#endif +import Data.Char (ord) +import GHC.Int (Int(..), Int32(..)) +import GHC.IO (IO(..), unIO) +import GHC.Prim +import GHC.Ptr (Ptr(..), plusPtr, castPtr) +import GHC.Types (isTrue#) +import GHC.Word (Word8, Word16(..), Word32(..), Word64(..)) +import qualified Foreign.Storable as S (poke) + +#include +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS < 64 && !MIN_VERSION_ghc_prim(0,8,0) +import GHC.IntWord64 +#endif + +import Data.ByteString.Builder.Prim.Internal.Floating + (castFloatToWord32, castDoubleToWord64) + +-- | Build a full bit-mask of specified length. +-- +-- e.g +-- +-- > showHex (mask 12) [] = "fff" +{-# INLINABLE mask #-} +mask :: (Bits a, Integral a) => Int -> a +mask = flip (-) 1 . unsafeShiftL 1 + +-- | Convert boolean false to 0 and true to 1 +{-# INLINABLE boolToWord32 #-} +boolToWord32 :: Bool -> Word32 +boolToWord32 = fromIntegral . fromEnum + +-- | Convert boolean false to 0 and true to 1 +{-# INLINABLE boolToWord64 #-} +boolToWord64 :: Bool -> Word64 +boolToWord64 = fromIntegral . fromEnum + +-- | Monomorphic conversion for @Int32 -> Int@ +{-# INLINABLE int32ToInt #-} +int32ToInt :: Int32 -> Int +int32ToInt = fromIntegral + +-- | Monomorphic conversion for @Int -> Int32@ +{-# INLINABLE intToInt32 #-} +intToInt32 :: Int -> Int32 +intToInt32 = fromIntegral + +-- | Monomorphic conversion for @Word32 -> Int@ +{-# INLINABLE word32ToInt #-} +word32ToInt :: Word32 -> Int +word32ToInt = fromIntegral + +-- | Monomorphic conversion for @Word64 -> Int@ +{-# INLINABLE word64ToInt #-} +word64ToInt :: Word64 -> Int +word64ToInt = fromIntegral + +-- | Monomorphic conversion for @Word32 -> Word64@ +{-# INLINABLE word32ToWord64 #-} +word32ToWord64 :: Word32 -> Word64 +word32ToWord64 = fromIntegral + +-- | Monomorphic conversion for @Word64 -> Word32@ +{-# INLINABLE word64ToWord32 #-} +word64ToWord32 :: Word64 -> Word32 +word64ToWord32 = fromIntegral + + +-- | Returns the number of decimal digits in v, which must not contain more than 9 digits. +decimalLength9 :: Word32 -> Int +decimalLength9 v + | v >= 100000000 = 9 + | v >= 10000000 = 8 + | v >= 1000000 = 7 + | v >= 100000 = 6 + | v >= 10000 = 5 + | v >= 1000 = 4 + | v >= 100 = 3 + | v >= 10 = 2 + | otherwise = 1 + +-- | Returns the number of decimal digits in v, which must not contain more than 17 digits. +decimalLength17 :: Word64 -> Int +decimalLength17 v + | v >= 10000000000000000 = 17 + | v >= 1000000000000000 = 16 + | v >= 100000000000000 = 15 + | v >= 10000000000000 = 14 + | v >= 1000000000000 = 13 + | v >= 100000000000 = 12 + | v >= 10000000000 = 11 + | v >= 1000000000 = 10 + | v >= 100000000 = 9 + | v >= 10000000 = 8 + | v >= 1000000 = 7 + | v >= 100000 = 6 + | v >= 10000 = 5 + | v >= 1000 = 4 + | v >= 100 = 3 + | v >= 10 = 2 + | otherwise = 1 + +-- From 'In-and-Out Conversions' https://dl.acm.org/citation.cfm?id=362887, we +-- have that a conversion from a base-b n-digit number to a base-v m-digit +-- number such that the round-trip conversion is identity requires +-- +-- v^(m-1) > b^n +-- +-- Specifically for binary floating point to decimal conversion, we must have +-- +-- 10^(m-1) > 2^n +-- => log(10^(m-1)) > log(2^n) +-- => (m-1) * log(10) > n * log(2) +-- => m-1 > n * log(2) / log(10) +-- => m-1 >= ceil(n * log(2) / log(10)) +-- => m >= ceil(n * log(2) / log(10)) + 1 +-- +-- And since 32 and 64-bit floats have 23 and 52 bits of mantissa (and then an +-- implicit leading-bit), we need +-- +-- ceil(24 * log(2) / log(10)) + 1 => 9 +-- ceil(53 * log(2) / log(10)) + 1 => 17 +-- +-- In addition, the exponent range from floats is [-45,38] and doubles is +-- [-324,308] (including subnormals) which are 3 and 4 digits respectively +-- +-- Thus we have, +-- +-- floats: 1 (sign) + 9 (mantissa) + 1 (.) + 1 (e) + 3 (exponent) = 15 +-- doubles: 1 (sign) + 17 (mantissa) + 1 (.) + 1 (e) + 4 (exponent) = 24 +-- +maxEncodedLength :: Int +maxEncodedLength = 32 + +-- | Storable.poke a String into a Ptr Word8, converting through c2w +pokeAll :: String -> Ptr Word8 -> IO (Ptr Word8) +pokeAll s ptr = foldM pokeOne ptr s + where pokeOne p c = S.poke p (c2w c) >> return (p `plusPtr` 1) + +-- | Unsafe creation of a bounded primitive of String at most length +-- `maxEncodedLength` +boundString :: String -> BoundedPrim () +boundString s = boundedPrim maxEncodedLength $ const (pokeAll s) + +-- | Special rendering for NaN, positive\/negative 0, and positive\/negative +-- infinity. These are based on the IEEE representation of non-numbers. +-- +-- Infinity +-- +-- * sign = 0 for positive infinity, 1 for negative infinity. +-- * biased exponent = all 1 bits. +-- * fraction = all 0 bits. +-- +-- NaN +-- +-- * sign = either 0 or 1 (ignored) +-- * biased exponent = all 1 bits. +-- * fraction = anything except all 0 bits. +-- +-- We also handle 0 specially here so that the exponent rendering is more +-- correct. +-- +-- * sign = either 0 or 1. +-- * biased exponent = all 0 bits. +-- * fraction = all 0 bits. +data NonNumbersAndZero = NonNumbersAndZero + { negative :: Bool + , exponent_all_one :: Bool + , mantissa_non_zero :: Bool + } + +-- | Renders NonNumbersAndZero into bounded primitive +toCharsNonNumbersAndZero :: NonNumbersAndZero -> BoundedPrim () +toCharsNonNumbersAndZero NonNumbersAndZero{..} + | mantissa_non_zero = boundString "NaN" + | exponent_all_one = boundString $ signStr ++ "Infinity" + | otherwise = boundString $ signStr ++ "0.0e0" + where signStr = if negative then "-" else "" + +-- | Part of the calculation on whether to round up the decimal representation. +-- This is currently a constant function to match behavior in Base `show` and +-- is implemented as +-- +-- @ +-- acceptBounds _ = False +-- @ +-- +-- For round-to-even and correct shortest, use +-- +-- @ +-- acceptBounds v = ((v \`quot\` 4) .&. 1) == 0 +-- @ +acceptBounds :: Mantissa a => a -> Bool +acceptBounds _ = False + +------------------------------------------------------------------------------- +-- Logarithm Approximations +-- +-- These are based on the same transformations. +-- +-- e.g +-- +-- log_2(5^e) goal function +-- = e * log_2(5) log exponenation +-- ~= e * floor(10^7 * log_2(5)) / 10^7 integer operations +-- ~= e * 1217359 / 2^19 approximation into n / 2^m +-- +-- These are verified in the unit tests for the given input ranges +------------------------------------------------------------------------------- + +-- | Returns e == 0 ? 1 : ceil(log_2(5^e)); requires 0 <= e <= 3528. +pow5bitsUnboxed :: Int# -> Int# +pow5bitsUnboxed e = (e *# 1217359#) `uncheckedIShiftRL#` 19# +# 1# + +-- | Returns floor(log_10(2^e)); requires 0 <= e <= 1650. +log10pow2Unboxed :: Int# -> Int# +log10pow2Unboxed e = (e *# 78913#) `uncheckedIShiftRL#` 18# + +-- | Returns floor(log_10(5^e)); requires 0 <= e <= 2620. +log10pow5Unboxed :: Int# -> Int# +log10pow5Unboxed e = (e *# 732923#) `uncheckedIShiftRL#` 20# + +-- | Boxed versions of the functions above +pow5bits, log10pow2, log10pow5 :: Int -> Int +pow5bits = wrapped pow5bitsUnboxed +log10pow2 = wrapped log10pow2Unboxed +log10pow5 = wrapped log10pow5Unboxed + +------------------------------------------------------------------------------- +-- Fast Division +-- +-- Division is slow. We leverage fixed-point arithmetic to calculate division +-- by a constant as multiplication by the inverse. This could potentially be +-- handled by an aggressive compiler, but to ensure that the optimization +-- happens, we hard-code the expected divisions / remainders by 5, 10, 100, etc +-- +-- e.g +-- +-- x / 5 goal function +-- = x * (1 / 5) reciprocal +-- = x * (4 / 5) / 4 +-- = x * 0b0.110011001100.. / 4 recurring binary representation +-- ~= x * (0xCCCCCCCD / 2^32) / 4 approximation with integers +-- = (x * 0xCCCCCCCD) >> 34 +-- +-- Look for `Reciprocal Multiplication, a tutorial` by Douglas W. Jones for a +-- more detailed explanation. +------------------------------------------------------------------------------- + +-- | Returns @w / 10@ +fquot10 :: Word32 -> Word32 +fquot10 w = word64ToWord32 ((word32ToWord64 w * 0xCCCCCCCD) `unsafeShiftR` 35) + +-- | Returns @w % 10@ +frem10 :: Word32 -> Word32 +frem10 w = w - fquot10 w * 10 + +-- | Returns @(w / 10, w % 10)@ +fquotRem10 :: Word32 -> (Word32, Word32) +fquotRem10 w = + let w' = fquot10 w + in (w', w - fquot10 w * 10) + +-- | Returns @w / 100@ +fquot100 :: Word32 -> Word32 +fquot100 w = word64ToWord32 ((word32ToWord64 w * 0x51EB851F) `unsafeShiftR` 37) + +-- | Returns @(w / 10000, w % 10000)@ +fquotRem10000 :: Word32 -> (Word32, Word32) +fquotRem10000 w = + let w' = word64ToWord32 ((word32ToWord64 w * 0xD1B71759) `unsafeShiftR` 45) + in (w', w - w' * 10000) + +-- | Returns @w / 5@ +fquot5 :: Word32 -> Word32 +fquot5 w = word64ToWord32 ((word32ToWord64 w * 0xCCCCCCCD) `unsafeShiftR` 34) + +-- | Returns @w % 5@ +frem5 :: Word32 -> Word32 +frem5 w = w - fquot5 w * 5 + +-- | Returns @w / 10@ +dquot10 :: Word64 -> Word64 +dquot10 w = + let !(rdx, _) = w `timesWord2` 0xCCCCCCCCCCCCCCCD + in rdx `unsafeShiftR` 3 + +-- | Returns @w / 100@ +dquot100 :: Word64 -> Word64 +dquot100 w = + let !(rdx, _) = (w `unsafeShiftR` 2) `timesWord2` 0x28F5C28F5C28F5C3 + in rdx `unsafeShiftR` 2 + +-- | Returns @(w / 10000, w % 10000)@ +dquotRem10000 :: Word64 -> (Word64, Word64) +dquotRem10000 w = + let !(rdx, _) = w `timesWord2` 0x346DC5D63886594B + w' = rdx `unsafeShiftR` 11 + in (w', w - w' * 10000) + +-- | Returns @(w / 10, w % 10)@ +dquotRem10 :: Word64 -> (Word64, Word64) +dquotRem10 w = + let w' = dquot10 w + in (w', w - w' * 10) + +-- | Returns @w / 5@ +dquot5 :: Word64 -> Word64 +dquot5 w = + let !(rdx, _) = w `timesWord2` 0xCCCCCCCCCCCCCCCD + in rdx `unsafeShiftR` 2 + +-- | Returns @w % 5@ +drem5 :: Word64 -> Word64 +drem5 w = w - dquot5 w * 5 + +-- | Returns @(w / 5, w % 5)@ +dquotRem5 :: Word64 -> (Word64, Word64) +dquotRem5 w = + let w' = dquot5 w + in (w', w - w' * 5) + +-- | Wrap a unboxed function on Int# into the boxed equivalent +wrapped :: (Int# -> Int#) -> Int -> Int +wrapped f (I# w) = I# (f w) + +#if WORD_SIZE_IN_BITS == 32 +-- | Packs 2 32-bit system words (hi, lo) into a Word64 +packWord64 :: Word# -> Word# -> Word64# +packWord64 hi lo = case hostByteOrder of + BigEndian -> + ((wordToWord64# lo) `uncheckedShiftL64#` 32#) `or64#` (wordToWord64# hi) + LittleEndian -> + ((wordToWord64# hi) `uncheckedShiftL64#` 32#) `or64#` (wordToWord64# lo) + +-- | Unpacks a Word64 into 2 32-bit words (hi, lo) +unpackWord64 :: Word64# -> (# Word#, Word# #) +unpackWord64 w = case hostByteOrder of + BigEndian -> + (# word64ToWord# w + , word64ToWord# (w `uncheckedShiftRL64#` 32#) + #) + LittleEndian -> + (# word64ToWord# (w `uncheckedShiftRL64#` 32#) + , word64ToWord# w + #) + +-- | Adds 2 Word64's with 32-bit addition and manual carrying +plusWord64 :: Word64# -> Word64# -> Word64# +plusWord64 x y = + let !(# x_h, x_l #) = unpackWord64 x + !(# y_h, y_l #) = unpackWord64 y + lo = x_l `plusWord#` y_l + carry = int2Word# (lo `ltWord#` x_l) + hi = x_h `plusWord#` y_h `plusWord#` carry + in packWord64 hi lo +#endif + +-- | Boxed version of `timesWord2#` for 64 bits +timesWord2 :: Word64 -> Word64 -> (Word64, Word64) +timesWord2 a b = + let ra = raw a + rb = raw b +#if WORD_SIZE_IN_BITS >= 64 +#if __GLASGOW_HASKELL__ < 903 + !(# hi, lo #) = ra `timesWord2#` rb +#else + !(# hi_, lo_ #) = word64ToWord# ra `timesWord2#` word64ToWord# rb + hi = wordToWord64# hi_ + lo = wordToWord64# lo_ +#endif +#else + !(# x_h, x_l #) = unpackWord64 ra + !(# y_h, y_l #) = unpackWord64 rb + + !(# phh_h, phh_l #) = x_h `timesWord2#` y_h + !(# phl_h, phl_l #) = x_h `timesWord2#` y_l + !(# plh_h, plh_l #) = x_l `timesWord2#` y_h + !(# pll_h, pll_l #) = x_l `timesWord2#` y_l + + -- x1 x0 + -- X y1 y0 + -- ------------- + -- 00 LOW PART + -- ------------- + -- 00 + -- 10 10 MIDDLE PART + -- + 01 + -- ------------- + -- 01 + -- + 11 11 HIGH PART + -- ------------- + + phh = packWord64 phh_h phh_l + phl = packWord64 phl_h phl_l + + !(# mh, ml #) = unpackWord64 (phl + `plusWord64` (wordToWord64# pll_h) + `plusWord64` (wordToWord64# plh_l)) + + hi = phh + `plusWord64` (wordToWord64# mh) + `plusWord64` (wordToWord64# plh_h) + + lo = packWord64 ml pll_l +#endif + in (W64# hi, W64# lo) + +-- | #ifdef for 64-bit word that seems to work on both 32- and 64-bit platforms +type WORD64 = +#if WORD_SIZE_IN_BITS < 64 || __GLASGOW_HASKELL__ >= 903 + Word64# +#else + Word# +#endif + +-- | Returns the number of times @w@ is divisible by @5@ +pow5_factor :: WORD64 -> Int# -> Int# +pow5_factor w count = + let !(W64# q, W64# r) = dquotRem5 (W64# w) +#if WORD_SIZE_IN_BITS >= 64 && __GLASGOW_HASKELL__ < 903 + in case r `eqWord#` 0## of +#else + in case r `eqWord64#` wordToWord64# 0## of +#endif + 0# -> count + _ -> pow5_factor q (count +# 1#) + +-- | Returns @True@ if value is divisible by @5^p@ +multipleOfPowerOf5 :: Mantissa a => a -> Int -> Bool +multipleOfPowerOf5 value (I# p) = isTrue# (pow5_factor (raw value) 0# >=# p) + +-- | Returns @True@ if value is divisible by @2^p@ +multipleOfPowerOf2 :: Mantissa a => a -> Int -> Bool +multipleOfPowerOf2 value p = (value .&. mask p) == 0 + +-- | Wrapper for polymorphic handling of 32- and 64-bit floats +class (FiniteBits a, Integral a) => Mantissa a where + -- NB: might truncate! + -- Use this when we know the value fits in 32-bits + unsafeRaw :: a -> Word# + raw :: a -> WORD64 + + decimalLength :: a -> Int + boolToWord :: Bool -> a + quotRem10 :: a -> (a, a) + quot10 :: a -> a + quot100 :: a -> a + quotRem100 :: a -> (a, a) + quotRem10000 :: a -> (a, a) + +instance Mantissa Word32 where +#if __GLASGOW_HASKELL__ >= 902 + unsafeRaw (W32# w) = word32ToWord# w +#else + unsafeRaw (W32# w) = w +#endif +#if WORD_SIZE_IN_BITS >= 64 && __GLASGOW_HASKELL__ < 903 + raw = unsafeRaw +#else + raw w = wordToWord64# (unsafeRaw w) +#endif + + decimalLength = decimalLength9 + boolToWord = boolToWord32 + + {-# INLINE quotRem10 #-} + quotRem10 = fquotRem10 + + {-# INLINE quot10 #-} + quot10 = fquot10 + + {-# INLINE quot100 #-} + quot100 = fquot100 + + quotRem100 w = + let w' = fquot100 w + in (w', (w - w' * 100)) + + quotRem10000 = fquotRem10000 + +instance Mantissa Word64 where +#if WORD_SIZE_IN_BITS >= 64 && __GLASGOW_HASKELL__ < 903 + unsafeRaw (W64# w) = w +#else + unsafeRaw (W64# w) = word64ToWord# w +#endif + raw (W64# w) = w + + decimalLength = decimalLength17 + boolToWord = boolToWord64 + + {-# INLINE quotRem10 #-} + quotRem10 = dquotRem10 + + {-# INLINE quot10 #-} + quot10 = dquot10 + + {-# INLINE quot100 #-} + quot100 = dquot100 + + quotRem100 w = + let w' = dquot100 w + in (w', (w - w' * 100)) + + quotRem10000 = dquotRem10000 + +-- | Bookkeeping state for finding the shortest, correctly-rounded +-- representation. The same trimming algorithm is similar enough for 32- and +-- 64-bit floats +data BoundsState a = BoundsState + { vu :: !a + , vv :: !a + , vw :: !a + , lastRemovedDigit :: !a + , vuIsTrailingZeros :: !Bool + , vvIsTrailingZeros :: !Bool + } + +-- | Trim digits and update bookkeeping state when the table-computed +-- step results in trailing zeros (the general case, happens rarely) +-- +-- NB: This function isn't actually necessary so long as acceptBounds is always +-- @False@ since we don't do anything different with the trailing-zero +-- information directly: +-- - vuIsTrailingZeros is always False. We can see this by noting that in all +-- places where vuTrailing can possible be True, we must have acceptBounds be +-- True (accept_smaller) +-- - The final result doesn't change the lastRemovedDigit for rounding anyway +trimTrailing :: (Show a, Mantissa a) => BoundsState a -> (BoundsState a, Int32) +trimTrailing !initial = (res, r + r') + where + !(d', r) = trimTrailing' initial + !(d'', r') = if vuIsTrailingZeros d' then trimTrailing'' d' else (d', 0) + res = if vvIsTrailingZeros d'' && lastRemovedDigit d'' == 5 && vv d'' `rem` 2 == 0 + -- set `{ lastRemovedDigit = 4 }` to round-even + then d'' + else d'' + + trimTrailing' !d + | vw' > vu' = + fmap ((+) 1) . trimTrailing' $ + d { vu = vu' + , vv = vv' + , vw = vw' + , lastRemovedDigit = vvRem + , vuIsTrailingZeros = vuIsTrailingZeros d && vuRem == 0 + , vvIsTrailingZeros = vvIsTrailingZeros d && lastRemovedDigit d == 0 + } + | otherwise = (d, 0) + where + !(vv', vvRem) = quotRem10 $ vv d + !(vu', vuRem) = quotRem10 $ vu d + !(vw', _ ) = quotRem10 $ vw d + + trimTrailing'' !d + | vuRem == 0 = + fmap ((+) 1) . trimTrailing'' $ + d { vu = vu' + , vv = vv' + , vw = vw' + , lastRemovedDigit = vvRem + , vvIsTrailingZeros = vvIsTrailingZeros d && lastRemovedDigit d == 0 + } + | otherwise = (d, 0) + where + !(vu', vuRem) = quotRem10 $ vu d + !(vv', vvRem) = quotRem10 $ vv d + !(vw', _ ) = quotRem10 $ vw d + + +-- | Trim digits and update bookkeeping state when the table-computed +-- step results has no trailing zeros (common case) +trimNoTrailing :: Mantissa a => BoundsState a -> (BoundsState a, Int32) +trimNoTrailing !(BoundsState u v w ld _ _) = + (BoundsState ru' rv' 0 ld' False False, c) + where + !(ru', rv', ld', c) = trimNoTrailing' u v w ld 0 + + trimNoTrailing' u' v' w' lastRemoved count + -- Loop iterations below (approximately), without div 100 optimization: + -- 0: 0.03%, 1: 13.8%, 2: 70.6%, 3: 14.0%, 4: 1.40%, 5: 0.14%, 6+: 0.02% + -- Loop iterations below (approximately), with div 100 optimization: + -- 0: 70.6%, 1: 27.8%, 2: 1.40%, 3: 0.14%, 4+: 0.02% + | vw' > vu' = + trimNoTrailing'' vu' vv' vw' (quot10 (v' - (vv' * 100))) (count + 2) + | otherwise = + trimNoTrailing'' u' v' w' lastRemoved count + where + !vw' = quot100 w' + !vu' = quot100 u' + !vv' = quot100 v' + + trimNoTrailing'' u' v' w' lastRemoved count + | vw' > vu' = trimNoTrailing' vu' vv' vw' lastRemoved' (count + 1) + | otherwise = (u', v', lastRemoved, count) + where + !(vv', lastRemoved') = quotRem10 v' + !vu' = quot10 u' + !vw' = quot10 w' + +-- | Returns the correctly rounded decimal representation mantissa based on if +-- we need to round up (next decimal place >= 5) or if we are outside the +-- bounds +{-# INLINE closestCorrectlyRounded #-} +closestCorrectlyRounded :: Mantissa a => Bool -> BoundsState a -> a +closestCorrectlyRounded acceptBound s = vv s + boolToWord roundUp + where + outsideBounds = not (vuIsTrailingZeros s) || not acceptBound + roundUp = (vv s == vu s && outsideBounds) || lastRemovedDigit s >= 5 + +-- Wrappe around int2Word# +asciiRaw :: Int -> Word# +asciiRaw (I# i) = int2Word# i + +asciiZero :: Int +asciiZero = ord '0' + +asciiDot :: Int +asciiDot = ord '.' + +asciiMinus :: Int +asciiMinus = ord '-' + +ascii_e :: Int +ascii_e = ord 'e' + +-- | Convert a single-digit number to the ascii ordinal e.g '1' -> 0x31 +toAscii :: Word# -> Word# +toAscii a = a `plusWord#` asciiRaw asciiZero + +-- | Index into the 64-bit word lookup table provided +{-# INLINE getWord64At #-} +getWord64At :: Ptr Word64 -> Int -> Word64 +getWord64At (Ptr arr) (I# i) = W64# (indexWord64OffAddr# arr i) + +-- | Index into the 128-bit word lookup table provided +-- Return (# high-64-bits , low-64-bits #) +-- +-- NB: The lookup tables we use store the low 64 bits in +-- host-byte-order then the high 64 bits in host-byte-order +{-# INLINE getWord128At #-} +getWord128At :: Ptr Word64 -> Int -> (Word64, Word64) +getWord128At (Ptr arr) (I# i) = let + !hi = W64# (indexWord64OffAddr# arr (i *# 2# +# 1#)) + !lo = W64# (indexWord64OffAddr# arr (i *# 2#)) + in (hi, lo) + +-- | Packs 2 bytes [lsb, msb] into 16-bit word +packWord16 :: Word# -> Word# -> Word# +packWord16 l h = case hostByteOrder of + BigEndian -> + (h `uncheckedShiftL#` 8#) `or#` l + LittleEndian -> + (l `uncheckedShiftL#` 8#) `or#` h + +-- | Unpacks a 16-bit word into 2 bytes [lsb, msb] +unpackWord16 :: Word# -> (# Word#, Word# #) +unpackWord16 w = case hostByteOrder of + BigEndian -> + (# w `and#` 0xff##, w `uncheckedShiftRL#` 8# #) + LittleEndian -> + (# w `uncheckedShiftRL#` 8#, w `and#` 0xff## #) + + +-- | Static array of 2-digit pairs 00..99 for faster ascii rendering +digit_table :: Ptr Word16 +digit_table = +#if PURE_HASKELL + castPtr Pure.digit_pairs_table +#else + castPtr c_digit_pairs_table + +foreign import ccall "&hs_bytestring_digit_pairs_table" + c_digit_pairs_table :: Ptr CChar +#endif + +-- | Unsafe index a static array for the 16-bit word at the index +unsafeAt :: Ptr Word16 -> Int# -> Word# +unsafeAt (Ptr a) i = +#if __GLASGOW_HASKELL__ >= 902 + word16ToWord# (indexWord16OffAddr# a i) +#else + indexWord16OffAddr# a i +#endif + +-- | Write a 16-bit word into the given address +copyWord16 :: Word# -> Addr# -> State# RealWorld -> State# RealWorld +copyWord16 w a s = let +#if __GLASGOW_HASKELL__ >= 902 + w16 = wordToWord16# w +#else + w16 = w +#endif + in case unIO (unalignedWriteU16 (W16# w16) (Ptr a)) s of + (# s', _ #) -> s' + +-- | Write an 8-bit word into the given address +poke :: Addr# -> Word# -> State# d -> State# d +poke a w s = +#if __GLASGOW_HASKELL__ >= 902 + writeWord8OffAddr# a 0# (wordToWord8# w) s +#else + writeWord8OffAddr# a 0# w s +#endif + +-- | Write the mantissa into the given address. This function attempts to +-- optimize this by writing pairs of digits simultaneously when the mantissa is +-- large enough +{-# SPECIALIZE writeMantissa :: Addr# -> Int# -> Word32 -> State# RealWorld -> (# Addr#, State# RealWorld #) #-} +{-# SPECIALIZE writeMantissa :: Addr# -> Int# -> Word64 -> State# RealWorld -> (# Addr#, State# RealWorld #) #-} +writeMantissa :: forall a. (Mantissa a) => Addr# -> Int# -> a -> State# RealWorld -> (# Addr#, State# RealWorld #) +writeMantissa ptr olength = go (ptr `plusAddr#` olength) + where + go p mantissa s1 + | mantissa >= 10000 = + let !(m', c) = quotRem10000 mantissa + !(c1, c0) = quotRem100 c + s2 = copyWord16 (digit_table `unsafeAt` word2Int# (unsafeRaw c0)) (p `plusAddr#` (-1#)) s1 + s3 = copyWord16 (digit_table `unsafeAt` word2Int# (unsafeRaw c1)) (p `plusAddr#` (-3#)) s2 + in go (p `plusAddr#` (-4#)) m' s3 + | mantissa >= 100 = + let !(m', c) = quotRem100 mantissa + s2 = copyWord16 (digit_table `unsafeAt` word2Int# (unsafeRaw c)) (p `plusAddr#` (-1#)) s1 + in finalize m' s2 + | otherwise = finalize mantissa s1 + finalize mantissa s1 + | mantissa >= 10 = + let !bs = digit_table `unsafeAt` word2Int# (unsafeRaw mantissa) + !(# lsb, msb #) = unpackWord16 bs + s2 = poke (ptr `plusAddr#` 2#) lsb s1 + s3 = poke (ptr `plusAddr#` 1#) (asciiRaw asciiDot) s2 + s4 = poke ptr msb s3 + in (# ptr `plusAddr#` (olength +# 1#), s4 #) + | (I# olength) > 1 = + let s2 = copyWord16 (packWord16 (asciiRaw asciiDot) (toAscii (unsafeRaw mantissa))) ptr s1 + in (# ptr `plusAddr#` (olength +# 1#), s2 #) + | otherwise = + let s2 = poke (ptr `plusAddr#` 2#) (asciiRaw asciiZero) s1 + s3 = poke (ptr `plusAddr#` 1#) (asciiRaw asciiDot) s2 + s4 = poke ptr (toAscii (unsafeRaw mantissa)) s3 + in (# ptr `plusAddr#` 3#, s4 #) + +-- | Write the exponent into the given address. +writeExponent :: Addr# -> Int32 -> State# RealWorld -> (# Addr#, State# RealWorld #) +writeExponent ptr !expo s1 + | expo >= 100 = + let !(e1, e0) = fquotRem10 (fromIntegral expo) -- TODO + s2 = copyWord16 (digit_table `unsafeAt` word2Int# (unsafeRaw e1)) ptr s1 + s3 = poke (ptr `plusAddr#` 2#) (toAscii (unsafeRaw e0)) s2 + in (# ptr `plusAddr#` 3#, s3 #) + | expo >= 10 = + let s2 = copyWord16 (digit_table `unsafeAt` e) ptr s1 + in (# ptr `plusAddr#` 2#, s2 #) + | otherwise = + let s2 = poke ptr (toAscii (int2Word# e)) s1 + in (# ptr `plusAddr#` 1#, s2 #) + where !(I# e) = int32ToInt expo + +-- | Write the sign into the given address. +writeSign :: Addr# -> Bool -> State# d -> (# Addr#, State# d #) +writeSign ptr True s1 = + let s2 = poke ptr (asciiRaw asciiMinus) s1 + in (# ptr `plusAddr#` 1#, s2 #) +writeSign ptr False s = (# ptr, s #) + +-- | Returns the decimal representation of a floating point number in +-- scientific (exponential) notation +{-# INLINABLE toCharsScientific #-} +{-# SPECIALIZE toCharsScientific :: Bool -> Word32 -> Int32 -> BoundedPrim () #-} +{-# SPECIALIZE toCharsScientific :: Bool -> Word64 -> Int32 -> BoundedPrim () #-} +toCharsScientific :: (Mantissa a) => Bool -> a -> Int32 -> BoundedPrim () +toCharsScientific !sign !mantissa !expo = boundedPrim maxEncodedLength $ \_ !(Ptr p0)-> do + let !olength@(I# ol) = decimalLength mantissa + !expo' = expo + intToInt32 olength - 1 + IO $ \s1 -> + let !(# p1, s2 #) = writeSign p0 sign s1 + !(# p2, s3 #) = writeMantissa p1 ol mantissa s2 + s4 = poke p2 (asciiRaw ascii_e) s3 + !(# p3, s5 #) = writeSign (p2 `plusAddr#` 1#) (expo' < 0) s4 + !(# p4, s6 #) = writeExponent p3 (abs expo') s5 + in (# s6, (Ptr p4) #) diff --git a/Data/ByteString/Builder/RealFloat/TableGenerator.hs b/Data/ByteString/Builder/RealFloat/TableGenerator.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/RealFloat/TableGenerator.hs @@ -0,0 +1,203 @@ +-- | +-- Module : Data.ByteString.Builder.RealFloat.TableGenerator +-- Copyright : (c) Lawrence Wu 2021 +-- License : BSD-style +-- Maintainer : lawrencejwu@gmail.com +-- +-- Constants and overview for compile-time table generation for Ryu internals +-- +-- This module uses Haskell's arbitrary-precision `Integer` types to compute +-- the necessary multipliers for efficient conversion to a decimal power base. +-- +-- It also exposes constants relevant to the 32- and 64-bit tables (e.g maximum +-- number of bits required to store the table values). + +module Data.ByteString.Builder.RealFloat.TableGenerator + ( float_pow5_inv_bitcount + , float_pow5_bitcount + , double_pow5_bitcount + , double_pow5_inv_bitcount + , float_max_split + , float_max_inv_split + , double_max_split + , double_max_inv_split + + , finv + , fnorm + , splitWord128s + , case64 + , case128 + ) where + +import GHC.Float (int2Double) + +import Data.Bits +import Data.Word +import Numeric + + +-- The basic floating point conversion algorithm is as such: +-- +-- Given floating point +-- +-- f = (-1)^s * m_f * 2^e_f +-- +-- which is IEEE encoded by `[s] [.. e ..] [.. m ..]`. `s` is the sign bit, `e` +-- is the biased exponent, and `m` is the mantissa, let +-- +-- | e /= 0 | e == 0 +-- -----+-------------------+----------- +-- m_f | 2^len(m) + m | m +-- e_f | e - bias - len(m) | 1 - bias - len(m) +-- +-- we compute the halfway points to the next smaller (`f-`) and larger (`f+`) +-- floating point numbers as +-- +-- lower halfway point u * 2^e2, u = 4 * m_f - (if m == 0 then 1 else 2) +-- v * 2^e2, v = 4 * m_f +-- upper halfway point w * 2^e2, u = 4 * m_f + 2 +-- where e2 = ef - 2 (so u, v, w are integers) +-- +-- +-- Then we compute (a, b, c) * 10^e10 = (u, v, w) * 2^e2 which is split into +-- the case of +-- +-- e2 >= 0 ==> e10 = 0 , (a, b, c) = (u, v, w) * 2^e2 +-- e2 < 0 ==> e10 = e2, (a, b, c) = (u, v, w) * 5^-e2 +-- +-- And finally we find the shortest representation from integers d0 and e0 such +-- that +-- +-- a * 10^e10 < d0 * 10^(e0+e10) < c * 10^e10 +-- +-- such that e0 is maximal (we allow equality to smaller or larger halfway +-- point depending on rounding mode). This is found through iteratively +-- dividing by 10 while a/10^j < c/10^j and doing some bookkeeping around +-- zeros. +-- +-- +-- +-- +-- The ryu algorithm removes the requirement for arbitrary precision arithmetic +-- and improves the runtime significantly by skipping most of the iterative +-- division by carefully selecting a point where certain invariants hold and +-- precomputing a few tables. +-- +-- Specifically, define `q` such that the correspondings values of a/10^q < +-- c/10^q - 1. We can prove (not shown) that +-- +-- if e2 >= 0, q = e2 * log_10(2) +-- if e2 < 0, q = -e2 * log_10(5) +-- +-- Then we can compute (a, b, c) / 10^q. Starting from (u, v, w) we have +-- +-- (a, b, c) / 10^q (a, b, c) / 10^q +-- = (u, v, w) * 2^e2 / 10^q OR = (u, v, w) * 5^-e2 / 10^q +-- +-- And since q < e2, +-- +-- = (u, v, w) * 2^e2-q / 5^q OR = (u, v, w) * 5^-e2-q / 2^q +-- +-- While (u, v, w) are n-bit numbers, 5^q and whatnot are significantly larger, +-- but we only need the top-most n bits of the result so we can choose `k` that +-- reduce the number of bits required to ~2n. We then multiply by either +-- +-- 2^k / 5^q OR 5^-e2-q / 2^k +-- +-- The required `k` is roughly linear in the exponent (we need more of the +-- multiplication to be precise) but the number of bits to store the +-- multiplicands above stays fixed. +-- +-- Since the number of bits needed is relatively small for IEEE 32- and 64-bit +-- floating types, we can compute appropriate values for `k` for the +-- floating-point-type-specific bounds instead of each e2. +-- +-- Finally, we need to do some final manual iterations potentially to do a +-- final fixup of the skipped state + + +-- | Bound for bits of @2^k / 5^q@ for floats +float_pow5_inv_bitcount :: Int +float_pow5_inv_bitcount = 59 + +-- | Bound for bits of @5^-e2-q / 2^k@ for floats +float_pow5_bitcount :: Int +float_pow5_bitcount = 61 + +-- | Bound for bits of @5^-e2-q / 2^k@ for doubles +double_pow5_bitcount :: Int +double_pow5_bitcount = 125 + +-- | Bound for bits of @2^k / 5^q@ for doubles +double_pow5_inv_bitcount :: Int +double_pow5_inv_bitcount = 125 + +-- NB: these tables are encoded directly into the +-- source code in cbits/aligned-static-hs-data.c + +-- | Number of bits in a positive integer +blen :: Integer -> Int +blen 0 = 0 +blen 1 = 1 +blen n = 1 + blen (n `quot` 2) + +-- | Used for table generation of 2^k / 5^q + 1 +finv :: Int -> Int -> Integer +finv bitcount i = + let p = 5^i + in (1 `shiftL` (blen p - 1 + bitcount)) `div` p + 1 + +-- | Used for table generation of 5^-e2-q / 2^k +fnorm :: Int -> Int -> Integer +fnorm bitcount i = + let p = 5^i + s = blen p - bitcount + in if s < 0 then p `shiftL` (-s) else p `shiftR` s + +-- | Breaks each integer into two Word64s (lowBits, highBits) +splitWord128s :: [Integer] -> [Word64] +splitWord128s li + = [fromInteger w | x <- li, w <- [x .&. maxWord64, x `shiftR` 64]] + where maxWord64 = toInteger (maxBound :: Word64) + +splitWord128 :: Integer -> (Word64,Word64) +splitWord128 x = (fromInteger (x `shiftR` 64), fromInteger (x .&. maxWord64)) + where maxWord64 = toInteger (maxBound :: Word64) + + +-- Helpers to generate case alternatives returning either one Word64 (case64) or +-- two Word64s (case128) for the PURE_HASKELL variant of the tables. +case64 :: (Int -> Integer) -> [Int] -> String +case64 f range = concat + [ show i ++ " -> 0x" ++ showHex (f i) "\n" + | i <- range] + +case128 :: (Int -> Integer) -> [Int] -> String +case128 f range = concat + [ show i ++ " -> (0x" ++ showHex hi "" ++ ", 0x" ++ showHex lo ")\n" + | i <- range + , let (hi,lo) = splitWord128 (f i) + ] + +-- Given a specific floating-point type, determine the range of q for the < 0 +-- and >= 0 cases +get_range :: forall ff. (RealFloat ff) => ff -> (Int, Int) +get_range f = + let (emin, emax) = floatRange f + mantissaDigits = floatDigits f + emin' = emin - mantissaDigits - 2 + emax' = emax - mantissaDigits - 2 + in ( (-emin') - floor (int2Double (-emin') * logBase 10 5) + , floor (int2Double emax' * logBase 10 2)) + +float_max_split :: Int -- = 46 +float_max_inv_split :: Int -- = 30 +(float_max_split, float_max_inv_split) = get_range (undefined :: Float) + +-- we take a slightly different codepath s.t we need one extra entry +double_max_split :: Int -- = 325 +double_max_inv_split :: Int -- = 291 +(double_max_split, double_max_inv_split) = + let (m, mi) = get_range (undefined :: Double) + in (m + 1, mi) + diff --git a/Data/ByteString/Char8.hs b/Data/ByteString/Char8.hs --- a/Data/ByteString/Char8.hs +++ b/Data/ByteString/Char8.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE CPP, BangPatterns #-} -{-# 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 @@ -44,162 +45,176 @@ module Data.ByteString.Char8 ( -- * The @ByteString@ type - ByteString, -- abstract, instances: Eq, Ord, Show, Read, Data, Typeable, Monoid + ByteString, -- * Introducing and eliminating 'ByteString's - empty, -- :: ByteString - singleton, -- :: Char -> ByteString - pack, -- :: String -> ByteString - unpack, -- :: ByteString -> String - B.fromStrict, -- :: ByteString -> Lazy.ByteString - B.toStrict, -- :: Lazy.ByteString -> ByteString + 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) - unsnoc, -- :: ByteString -> Maybe (ByteString, Char) - 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, -- * 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 + 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 - takeEnd, -- :: Int -> ByteString -> ByteString - drop, -- :: Int -> ByteString -> ByteString - dropEnd, -- :: Int -> ByteString -> ByteString - splitAt, -- :: Int -> ByteString -> (ByteString, ByteString) - takeWhile, -- :: (Char -> Bool) -> ByteString -> ByteString - takeWhileEnd, -- :: (Char -> Bool) -> ByteString -> ByteString - dropWhile, -- :: (Char -> Bool) -> ByteString -> ByteString - dropWhileEnd, -- :: (Char -> Bool) -> ByteString -> ByteString - dropSpace, -- :: 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] - strip, -- :: ByteString -> ByteString - stripPrefix, -- :: ByteString -> ByteString -> Maybe ByteString - stripSuffix, -- :: ByteString -> ByteString -> Maybe 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) + 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 - indexMaybe, -- :: ByteString -> Int -> Maybe Char - (!?), -- :: ByteString -> Int -> Maybe 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] - findIndexEnd, -- :: (Char -> Bool) -> ByteString -> Maybe 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] - packZipWith, -- :: (Char -> Char -> Char) -> ByteString -> ByteString -> ByteString - 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 @@ -207,40 +222,40 @@ -- newline mode is considered a flaw and may be changed in a future version. -- ** Standard input and output - getLine, -- :: IO ByteString - getContents, -- :: IO ByteString - putStr, -- :: ByteString -> IO () - putStrLn, -- :: ByteString -> IO () - interact, -- :: (ByteString -> ByteString) -> IO () + getLine, + getContents, + putStr, + putStrLn, + interact, -- ** Files - readFile, -- :: FilePath -> IO ByteString - writeFile, -- :: FilePath -> ByteString -> IO () - appendFile, -- :: FilePath -> ByteString -> IO () --- mmapFile, -- :: FilePath -> IO ByteString + readFile, + writeFile, + appendFile, +-- mmapFile, -- ** I\/O with Handles - hGetLine, -- :: Handle -> IO ByteString - hGetContents, -- :: Handle -> IO ByteString - hGet, -- :: Handle -> Int -> IO ByteString - 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 () + 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) @@ -249,33 +264,29 @@ import qualified Data.ByteString.Unsafe as B -- Listy functions transparently exported -import Data.ByteString (empty,null,length,tail,init,append - ,inits,tails,reverse,transpose +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 + ,getContents, putStr, interact ,readFile, writeFile, appendFile ,hGetContents, hGet, hGetSome, hPut, hPutStr - ,hGetLine, hGetNonBlocking, hPutNonBlocking + ,hGetNonBlocking, hPutNonBlocking ,packCString,packCStringLen ,useAsCString,useAsCStringLen ) -import Data.ByteString.Internal - -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative ((<$>)) -#endif +import Data.ByteString.Internal.Type +import Data.ByteString.ReadInt +import Data.ByteString.ReadNat import Data.Char ( isSpace ) -#if MIN_VERSION_base(4,9,0) -- See bytestring #70 import GHC.Char (eqChar) -#endif -import qualified Data.List as List (intersperse) +import qualified Data.List as List import System.IO (Handle,stdout) import Foreign @@ -430,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)) @@ -529,7 +540,7 @@ dropWhile isSpace = dropSpace #-} --- | 'dropWhile' @p xs@ returns the prefix remaining after 'takeWhileEnd' @p +-- | 'dropWhileEnd' @p xs@ returns the prefix remaining after 'takeWhileEnd' @p -- xs@. -- -- @since 0.10.12.0 @@ -543,25 +554,16 @@ {-# INLINE [1] break #-} -- See bytestring #70 -#if MIN_VERSION_base(4,9,0) {-# RULES "ByteString specialise break (x==)" forall x. break (x `eqChar`) = breakChar x "ByteString specialise break (==x)" forall x. break (`eqChar` x) = breakChar x #-} -#else -{-# RULES -"ByteString specialise break (x==)" forall x. - break (x ==) = breakChar x -"ByteString specialise break (==x)" forall x. - break (== x) = breakChar x - #-} -#endif -- 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. -- @@ -720,7 +722,6 @@ findIndices f = B.findIndices (f . w2c) {-# INLINE [1] findIndices #-} -#if MIN_VERSION_base(4,9,0) {-# RULES "ByteString specialise findIndex (x==)" forall x. findIndex (x `eqChar`) = elemIndex x @@ -731,18 +732,6 @@ "ByteString specialise findIndices (==x)" forall x. findIndices (`eqChar` x) = elemIndices x #-} -#else -{-# RULES -"ByteString specialise findIndex (x==)" forall x. - findIndex (x==) = elemIndex x -"ByteString specialise findIndex (==x)" forall x. - findIndex (==x) = elemIndex x -"ByteString specialise findIndices (x==)" forall x. - findIndices (x==) = elemIndices x -"ByteString specialise findIndices (==x)" forall x. - findIndices (==x) = elemIndices x - #-} -#endif -- | count returns the number of times its argument appears in the ByteString @@ -872,14 +861,6 @@ 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 @@ -988,13 +969,22 @@ 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] @@ -1006,91 +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. --- --- Note: This function will overflow the Int for large integers. -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) - 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) - 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 : combine2 b ns - combine2 _ ns = ns - ------------------------------------------------------------------------ -- For non-binary text processing: --- | Write a ByteString to a handle, appending a newline byte +-- | 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. +-- +-- 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 --- | Write a ByteString to stdout, appending a newline byte +-- | Write a ByteString to 'stdout', appending a newline byte. +-- +-- Unlike 'putStr', this is not atomic: other threads might write +-- to 'stdout' between writing of the bytestring and the newline. +-- putStrLn :: ByteString -> IO () putStrLn = hPutStrLn stdout diff --git a/Data/ByteString/Internal.hs b/Data/ByteString/Internal.hs --- a/Data/ByteString/Internal.hs +++ b/Data/ByteString/Internal.hs @@ -1,14 +1,3 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-} -{-# LANGUAGE UnliftedFFITypes, MagicHash, - UnboxedTuples, DeriveDataTypeable #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE PatternSynonyms, ViewPatterns #-} -#endif -#if __GLASGOW_HASKELL__ >= 703 -{-# LANGUAGE Unsafe #-} -#endif {-# OPTIONS_HADDOCK not-home #-} -- | @@ -33,11 +22,11 @@ -- * The @ByteString@ type and representation ByteString ( BS -#if __GLASGOW_HASKELL__ >= 800 , PS -- backwards compatibility shim -#endif - ), -- instances: Eq, Ord, Show, Read, Data, Typeable + ), + StrictByteString, + -- * Internal indexing findIndexOrLength, @@ -46,806 +35,62 @@ packChars, packUptoLenChars, unsafePackLenChars, unpackBytes, unpackAppendBytesLazy, unpackAppendBytesStrict, unpackChars, unpackAppendCharsLazy, unpackAppendCharsStrict, - unsafePackAddress, unsafePackLiteral, + unsafePackAddress, unsafePackLenAddress, + unsafePackLiteral, unsafePackLenLiteral, -- * Low level imperative construction - create, -- :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString - createUptoN, -- :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString - createUptoN', -- :: Int -> (Ptr Word8 -> IO (Int, a)) -> IO (ByteString, a) - 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 - unsafeCreateUptoN, -- :: Int -> (Ptr Word8 -> IO Int) -> ByteString - unsafeCreateUptoN', -- :: Int -> (Ptr Word8 -> IO (Int, a)) -> (ByteString, a) - mallocByteString, -- :: Int -> IO (ForeignPtr a) + empty, + create, + createUptoN, + createUptoN', + createAndTrim, + createAndTrim', + unsafeCreate, + unsafeCreateUptoN, + unsafeCreateUptoN', + mallocByteString, -- * Conversion to and from ForeignPtrs - fromForeignPtr, -- :: ForeignPtr Word8 -> Int -> Int -> ByteString - toForeignPtr, -- :: ByteString -> (ForeignPtr Word8, Int, Int) - fromForeignPtr0, -- :: ForeignPtr Word8 -> Int -> ByteString - toForeignPtr0, -- :: ByteString -> (ForeignPtr Word8, Int) + mkDeferredByteString, + fromForeignPtr, + toForeignPtr, + fromForeignPtr0, + toForeignPtr0, -- * Utilities - nullForeignPtr, -- :: ForeignPtr Word8 - checkedAdd, -- :: String -> Int -> Int -> Int + nullForeignPtr, + deferForeignPtrAvailability, + SizeOverflowException, + overflowError, + checkedAdd, + checkedMultiply, -- * Standard C Functions - c_strlen, -- :: CString -> IO CInt - c_free_finalizer, -- :: FunPtr (Ptr Word8 -> IO ()) + c_strlen, + c_free_finalizer, - memchr, -- :: Ptr Word8 -> Word8 -> CSize -> IO Ptr Word8 - memcmp, -- :: Ptr Word8 -> Ptr Word8 -> Int -> IO CInt - memcpy, -- :: Ptr Word8 -> Ptr Word8 -> Int -> IO () - memset, -- :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8) + memchr, + memcmp, + memcpy, + memset, -- * cbits functions - c_reverse, -- :: Ptr Word8 -> Ptr Word8 -> CSize -> IO () - c_intersperse, -- :: Ptr Word8 -> Ptr Word8 -> CSize -> Word8 -> IO () - c_maximum, -- :: Ptr Word8 -> CSize -> IO Word8 - c_minimum, -- :: Ptr Word8 -> CSize -> IO Word8 - c_count, -- :: Ptr Word8 -> CSize -> Word8 -> IO CSize - c_sort, -- :: Ptr Word8 -> CSize -> IO () + c_reverse, + c_intersperse, + c_maximum, + c_minimum, + c_count, + c_sort, -- * Chars w2c, c2w, isSpaceWord8, isSpaceChar8, -- * Deprecated and unmentionable - accursedUnutterablePerformIO, -- :: IO a -> a + accursedUnutterablePerformIO, -- * Exported compatibility shim plusForeignPtr, unsafeWithForeignPtr ) where -import Prelude hiding (concat, null) -import qualified Data.List as List - -import Control.Monad (void) - -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) -import Foreign.Ptr (Ptr, FunPtr, plusPtr, minusPtr) -import Foreign.Storable (Storable(..)) - -#if MIN_VERSION_base(4,5,0) || __GLASGOW_HASKELL__ >= 703 -import Foreign.C.Types (CInt(..), CSize(..)) -#else -import Foreign.C.Types (CInt, CSize) -#endif - -import Foreign.C.String (CString) - -#if MIN_VERSION_base(4,13,0) -import Data.Semigroup (Semigroup (sconcat, stimes)) -import Data.List.NonEmpty (NonEmpty ((:|))) -#elif MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup ((<>), sconcat, stimes)) -import Data.List.NonEmpty (NonEmpty ((:|))) -#endif - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid (Monoid(..)) -#endif - - -import Control.DeepSeq (NFData(rnf)) - -import Data.String (IsString(..)) - -import Control.Exception (assert) - -import Data.Bits ((.&.)) -import Data.Char (ord) -import Data.Word - -import Data.Typeable (Typeable) -import Data.Data (Data(..), mkNoRepType) - -import GHC.Base (nullAddr#,realWorld#,unsafeChr) - -#if MIN_VERSION_base(4,7,0) -import GHC.Exts (IsList(..)) -#endif - -#if MIN_VERSION_base(4,4,0) -import GHC.CString (unpackCString#) -#else -import GHC.Base (unpackCString#) -#endif - -import GHC.Prim (Addr#) - -import GHC.IO (IO(IO),unsafeDupablePerformIO) - -import GHC.ForeignPtr (ForeignPtr(ForeignPtr) -#if __GLASGOW_HASKELL__ < 900 - , newForeignPtr_ -#endif - , mallocPlainForeignPtrBytes) - -#if MIN_VERSION_base(4,10,0) -import GHC.ForeignPtr (plusForeignPtr) -#else -import GHC.Prim (plusAddr#) -#endif - -#if __GLASGOW_HASKELL__ >= 811 -import GHC.CString (cstringLength#) -import GHC.ForeignPtr (ForeignPtrContents(FinalPtr)) -#else -import GHC.Ptr (Ptr(..), castPtr) -#endif - -#if (__GLASGOW_HASKELL__ < 802) || (__GLASGOW_HASKELL__ >= 811) -import GHC.Types (Int (..)) -#endif - -#if MIN_VERSION_base(4,15,0) -import GHC.ForeignPtr (unsafeWithForeignPtr) -#endif - -#if !MIN_VERSION_base(4,15,0) -unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b -unsafeWithForeignPtr = withForeignPtr -#endif - --- CFILES stuff is Hugs only -{-# CFILES cbits/fpstring.c #-} - -#if !MIN_VERSION_base(4,10,0) --- |Advances the given address by the given offset in bytes. --- --- The new 'ForeignPtr' shares the finalizer of the original, --- equivalent from a finalization standpoint to just creating another --- reference to the original. That is, the finalizer will not be --- called before the new 'ForeignPtr' is unreachable, nor will it be --- called an additional time due to this call, and the finalizer will --- be called with the same address that it would have had this call --- not happened, *not* the new address. -plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b -plusForeignPtr (ForeignPtr addr guts) (I# offset) = ForeignPtr (plusAddr# addr offset) guts -{-# INLINE [0] plusForeignPtr #-} -{-# RULES -"ByteString plusForeignPtr/0" forall fp . - plusForeignPtr fp 0 = fp - #-} -#endif - --- ----------------------------------------------------------------------------- - --- | 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 - deriving (Typeable) - - -#if __GLASGOW_HASKELL__ >= 800 --- | --- @'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 -#if __GLASGOW_HASKELL__ >= 802 -{-# COMPLETE PS #-} -#endif -#endif - -instance Eq ByteString where - (==) = eq - -instance Ord ByteString where - compare = compareBytes - -#if MIN_VERSION_base(4,9,0) -instance Semigroup ByteString where - (<>) = append - sconcat (b:|bs) = concat (b:bs) - stimes = times -#endif - -instance Monoid ByteString where - mempty = BS nullForeignPtr 0 -#if MIN_VERSION_base(4,9,0) - mappend = (<>) -#else - mappend = append -#endif - 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 ] - -#if MIN_VERSION_base(4,7,0) --- | @since 0.10.12.0 -instance IsList ByteString where - type Item ByteString = Word8 - fromList = packBytes - toList = unpackBytes -#endif - --- | 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 _ = error "Data.ByteString.ByteString.toConstr" - gunfold _ _ = error "Data.ByteString.ByteString.gunfold" - dataTypeOf _ = mkNoRepType "Data.ByteString.ByteString" - ------------------------------------------------------------------------- --- 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 $ withForeignPtr x g - where - g ptr = go 0 - where - go !n | n >= l = return l - | otherwise = do w <- peek $ ptr `plusPtr` 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 = - unsafeCreate len $ \p -> go p xs0 - where - go !_ [] = return () - go !p (x:xs) = poke p x >> go (p `plusPtr` 1) xs - -unsafePackLenChars :: Int -> [Char] -> ByteString -unsafePackLenChars len cs0 = - unsafeCreate len $ \p -> go p cs0 - where - go !_ [] = return () - go !p (c:cs) = poke p (c2w c) >> go (p `plusPtr` 1) cs - - --- | /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 __GLASGOW_HASKELL__ >= 811 - return (BS (ForeignPtr addr# FinalPtr) (I# (cstringLength# addr#))) -#else - p <- newForeignPtr_ (castPtr cstr) - l <- c_strlen cstr - return $ BS p (fromIntegral l) - where - cstr :: CString - cstr = Ptr addr# -#endif -{-# INLINE unsafePackAddress #-} - --- | 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@. -unsafePackLiteral :: Addr# -> ByteString -unsafePackLiteral addr# = -#if __GLASGOW_HASKELL__ >= 811 - BS (ForeignPtr addr# FinalPtr) (I# (cstringLength# addr#)) -#else - let len = accursedUnutterablePerformIO (c_strlen (Ptr addr#)) - in BS (accursedUnutterablePerformIO (newForeignPtr_ (Ptr addr#))) (fromIntegral len) -#endif -{-# INLINE unsafePackLiteral #-} - - -packUptoLenBytes :: Int -> [Word8] -> (ByteString, [Word8]) -packUptoLenBytes len xs0 = - unsafeCreateUptoN' len $ \p0 -> - let p_end = plusPtr p0 len - go !p [] = return (p `minusPtr` p0, []) - go !p xs | p == p_end = return (len, xs) - go !p (x:xs) = poke p x >> go (p `plusPtr` 1) xs - in go p0 xs0 - -packUptoLenChars :: Int -> [Char] -> (ByteString, [Char]) -packUptoLenChars len cs0 = - unsafeCreateUptoN' len $ \p0 -> - let p_end = plusPtr p0 len - go !p [] = return (p `minusPtr` p0, []) - go !p cs | p == p_end = return (len, cs) - go !p (c:cs) = poke p (c2w c) >> go (p `plusPtr` 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 __GLASGOW_HASKELL__ >= 811 -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 do 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 #-} - -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 -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. -unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> ByteString -unsafeCreate l f = unsafeDupablePerformIO (create l 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 = unsafeDupablePerformIO (createUptoN l f) -{-# INLINE unsafeCreateUptoN #-} - --- | @since 0.10.12.0 -unsafeCreateUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> (ByteString, a) -unsafeCreateUptoN' l f = unsafeDupablePerformIO (createUptoN' l 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 f = do - fp <- mallocByteString l - withForeignPtr fp $ \p -> f p - return $! BS fp l -{-# 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 f = do - fp <- mallocByteString l - l' <- withForeignPtr fp $ \p -> f p - assert (l' <= l) $ return $! BS fp l' -{-# 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 f = do - fp <- mallocByteString l - (l', res) <- withForeignPtr fp $ \p -> f p - assert (l' <= l) $ return (BS fp l', res) -{-# 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 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 $! BS fp l - else create l' $ \p' -> memcpy p' p l' -{-# INLINE createAndTrim #-} - -createAndTrim' :: Int -> (Ptr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a) -createAndTrim' l f = do - fp <- mallocByteString l - withForeignPtr fp $ \p -> do - (off, l', res) <- f p - if assert (l' <= l) $ l' >= l - then return (BS fp l, res) - else do ps <- create l' $ \p' -> - memcpy p' (p `plusPtr` off) l' - return (ps, res) - --- | 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 - -append :: ByteString -> ByteString -> ByteString -append (BS _ 0) b = b -append a (BS _ 0) = a -append (BS fp1 len1) (BS fp2 len2) = - unsafeCreate (len1+len2) $ \destptr1 -> do - let destptr2 = destptr1 `plusPtr` len1 - unsafeWithForeignPtr fp1 $ \p1 -> memcpy destptr1 p1 len1 - unsafeWithForeignPtr fp2 $ \p2 -> memcpy destptr2 p2 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 _ [] = mempty - 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 [] = - unsafeCreate 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 - unsafeWithForeignPtr fp $ \p -> memcpy ptr p len - goCopy bss (ptr `plusPtr` len) -{-# NOINLINE concat #-} - -{-# RULES -"ByteString concat [] -> mempty" - concat [] = mempty -"ByteString concat [bs] -> bs" forall x. - concat [x] = x - #-} - -#if MIN_VERSION_base(4,9,0) --- | /O(log n)/ Repeats the given ByteString n times. -times :: Integral a => a -> ByteString -> ByteString -times n (BS fp len) - | n < 0 = error "stimes: non-negative multiplier expected" - | n == 0 = mempty - | n == 1 = BS fp len - | len == 0 = mempty - | len == 1 = unsafeCreate size $ \destptr -> - unsafeWithForeignPtr fp $ \p -> do - byte <- peek p - void $ memset destptr byte (fromIntegral size) - | otherwise = unsafeCreate size $ \destptr -> - unsafeWithForeignPtr fp $ \p -> do - memcpy destptr p len - fillFrom destptr len - where - size = len * fromIntegral n - - fillFrom :: Ptr Word8 -> Int -> IO () - fillFrom destptr copied - | 2 * copied < size = do - memcpy (destptr `plusPtr` copied) destptr copied - fillFrom destptr (copied * 2) - | otherwise = memcpy (destptr `plusPtr` copied) destptr (size - copied) -#endif - --- | Add two non-negative numbers. Errors out on overflow. -checkedAdd :: String -> Int -> Int -> Int -checkedAdd fun x y - | r >= 0 = r - | otherwise = overflowError fun - where r = x + y -{-# INLINE checkedAdd #-} - ------------------------------------------------------------------------- - --- | 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 #-} - -overflowError :: String -> a -overflowError fun = error $ "Data.ByteString." ++ fun ++ ": size overflow" - ------------------------------------------------------------------------- - --- | This \"function\" has a superficial similarity to 'System.IO.Unsafe.unsafePerformIO' but --- it is in fact a malevolent agent of chaos. It unpicks the seams of reality --- (and the 'IO' monad) so that the normal rules no longer apply. It lulls you --- into thinking it is reasonable, but when you are not looking it stabs you --- in the back and aliases all of your mutable buffers. The carcass of many a --- seasoned Haskell programmer lie strewn at its feet. --- --- Witness the trail of destruction: --- --- * --- --- * --- --- * --- --- * --- --- * --- --- Do not talk about \"safe\"! You do not know what is safe! --- --- Yield not to its blasphemous call! Flee traveller! Flee or you will be --- corrupted and devoured! --- -{-# INLINE accursedUnutterablePerformIO #-} -accursedUnutterablePerformIO :: IO a -> a -accursedUnutterablePerformIO (IO m) = case m realWorld# of (# _, r #) -> r - --- --------------------------------------------------------------------- --- --- Standard C functions --- - -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 = c_memchr p (fromIntegral w) - -foreign import ccall unsafe "string.h memcmp" c_memcmp - :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt - -memcmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO CInt -memcmp p q s = c_memcmp p q (fromIntegral s) - -foreign import ccall unsafe "string.h memcpy" c_memcpy - :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8) - -memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () -memcpy p q s = void $ c_memcpy p q (fromIntegral s) - -{- -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 = c_memset p (fromIntegral w) - --- --------------------------------------------------------------------- --- --- Uses our C code --- - -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 - -foreign import ccall unsafe "static fpstring.h fps_sort" c_sort - :: Ptr Word8 -> CSize -> IO () +import Data.ByteString.Internal.Type diff --git a/Data/ByteString/Internal/Pure.hs b/Data/ByteString/Internal/Pure.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Internal/Pure.hs @@ -0,0 +1,418 @@ +-- Enable yields to make `isValidUtf8` safe to use on large inputs. +{-# OPTIONS_GHC -fno-omit-yields #-} + +-- | Haskell implementation of C bits +module Data.ByteString.Internal.Pure + ( -- * standard string.h functions + strlen + , memchr + , memcmp + -- * fpstring.c + , intersperse + , countOcc + , countOccBA + , reverseBytes + , findMaximum + , findMinimum + , quickSort + , elemIndex + , isValidUtf8 + , isValidUtf8BA + -- * itoa.c + , encodeSignedDec + , encodeUnsignedDec + , encodeUnsignedDecPadded + , encodeUnsignedHex + -- * static tables (unaligned!) + , lower_hex_table + , digit_pairs_table + ) +where + +import Prelude + +import GHC.Exts (Ptr(..), ByteArray#, indexWord8Array#, Word8#, Int#, indexWord8OffAddr#) +import GHC.Types (Int (..)) +import GHC.Word (Word8(..)) +import GHC.Int (Int8(..)) + +import Data.Bits (Bits(..), shiftR, (.&.)) +import Data.Word +import Foreign.Ptr (plusPtr, nullPtr) +import Foreign.Storable (Storable(..)) +import Control.Monad (when) +import Control.Exception (assert) + +import Data.ByteString.Utils.ByteOrder +import Data.ByteString.Utils.UnalignedAccess + +---------------------------------------------------------------- +-- Haskell versions of standard functions in string.h +---------------------------------------------------------------- + +strlen :: Ptr Word8 -> IO Int +strlen = go 0 where + go :: Int -> Ptr Word8 -> IO Int + go !acc !p = do + c <- peek p + if | c == 0 -> pure acc + | nextAcc <- acc + 1 + , nextAcc >= 0 -> go nextAcc (p `plusPtr` 1) + | otherwise -> errorWithoutStackTrace + "bytestring: strlen: String length does not fit in a Haskell Int" + +memchr :: Ptr Word8 -> Word8 -> Int -> IO (Ptr Word8) +memchr !p !target !len + | len == 0 = pure nullPtr + | otherwise = assert (len > 0) $ do + c <- peek p + if c == target + then pure p + else memchr (p `plusPtr` 1) target (len - 1) + +memcmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO Int +memcmp !p1 !p2 !len + | len >= 8 = do + w1 <- unalignedReadU64 p1 + w2 <- unalignedReadU64 p2 + let toBigEndian = whenLittleEndian byteSwap64 + if | w1 == w2 + -> memcmp (p1 `plusPtr` 8) (p2 `plusPtr` 8) (len - 8) + | toBigEndian w1 < toBigEndian w2 + -> pure (0-1) + | otherwise -> pure 1 + | otherwise = memcmp1 p1 p2 len + +-- | Like 'memcmp', but definitely scans one byte at a time +memcmp1 :: Ptr Word8 -> Ptr Word8 -> Int -> IO Int +memcmp1 !p1 !p2 !len + | len == 0 = pure 0 + | otherwise = assert (len > 0) $ do + c1 <- peek p1 + c2 <- peek p2 + if | c1 == c2 -> memcmp1 (p1 `plusPtr` 1) (p2 `plusPtr` 1) (len - 1) + | c1 < c2 -> pure (0-1) + | otherwise -> pure 1 + + +---------------------------------------------------------------- +-- Haskell versions of functions in fpstring.c +---------------------------------------------------------------- + +-- | duplicate a string, interspersing the character through the elements of the +-- duplicated string +intersperse :: Ptr Word8 -> Ptr Word8 -> Int -> Word8 -> IO () +intersperse !dst !src !len !w = case len of + 0 -> pure () + 1 -> do + -- copy last char + c <- peekByteOff src 0 + pokeByteOff dst 0 (c :: Word8) + _ -> do + c <- peekByteOff src 0 + pokeByteOff dst 0 (c :: Word8) + pokeByteOff dst 1 w + intersperse (plusPtr dst 2) (plusPtr src 1) (len-1) w + +countOccBA :: ByteArray# -> Int -> Word8 -> IO Int +countOccBA ba len w = pure (go 0 0) + where + go !n !i@(I# i#) + | i == len = n + | W8# (indexWord8Array# ba i#) == w = go (n+1) (i+1) + | otherwise = go n (i+1) + +countOcc :: Ptr Word8 -> Int -> Word8 -> IO Int +countOcc p len w = go 0 0 + where + go !n !i + | i == len = pure n + | otherwise = do + c <- peekByteOff p i + if c == w + then go (n+1) (i+1) + else go n (i+1) + +-- | Haskell equivalent of C `sbs_elem_index` +elemIndex :: ByteArray# -> Word8 -> Int -> IO Int +elemIndex !ba !w !len = pure (go 0) + where + go !i@(I# i#) + | i == len = -1 + | W8# (indexWord8Array# ba i#) == w = i + | otherwise = go (i+1) + +-- | Reverse n-bytes from the second pointer into the first +reverseBytes :: Ptr Word8 -> Ptr Word8 -> Int -> IO () +reverseBytes !dst !src !n + | n == 0 = pure () + | otherwise = reverse_bytes dst (plusPtr dst (n - 1)) src + +-- | Note that reverse_bytes reverses at least one byte. +-- Then it loops if necessary until the destination buffer is full +reverse_bytes :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO () +reverse_bytes orig_dst dst src = do + c <- peekByteOff src 0 + pokeByteOff dst 0 (c :: Word8) + if orig_dst == dst + then pure () + else reverse_bytes orig_dst (plusPtr dst (-1)) (plusPtr src 1) + + +findMaximum :: Ptr Word8 -> Int -> IO Word8 +findMaximum !p !n = assert (n > 0) $ find_maximum minBound p (plusPtr p (n - 1)) + +find_maximum :: Word8 -> Ptr Word8 -> Ptr Word8 -> IO Word8 +find_maximum !m !p !plast = do + c <- peekByteOff p 0 + let !c' = if c > m then c else m + if p == plast + then pure c' + else find_maximum c' (plusPtr p 1) plast + +findMinimum :: Ptr Word8 -> Int -> IO Word8 +findMinimum !p !n = assert (n > 0) $ find_minimum maxBound p (plusPtr p (n - 1)) + +find_minimum :: Word8 -> Ptr Word8 -> Ptr Word8 -> IO Word8 +find_minimum !m !p !plast = do + c <- peekByteOff p 0 + let !c' = if c < m then c else m + if p == plast + then pure c' + else find_minimum c' (plusPtr p 1) plast + + +quickSort :: Ptr Word8 -> Int -> IO () +quickSort !p !n + | n <= 0 = pure () + | otherwise = quick_sort p 0 (n - 1) + +quick_sort :: Ptr Word8 -> Int -> Int -> IO () +quick_sort !p !low !high + | low >= high = pure () + | otherwise = do + pivot_index <- partition p low high + quick_sort p low (pivot_index-1) + quick_sort p (pivot_index+1) high + + +partition :: Ptr Word8 -> Int -> Int -> IO Int +partition !p !low !high = do + -- choose the rightmost element as the pivot + pivot <- peekByteOff p high :: IO Word8 + -- traverse through all elements. + -- swap element smaller than pivot at index j with leftmost element at + -- index i greater than pivot (can be itself if no greater element read yet) + let go !i !j + | j > high = pure (i-1) + | otherwise = do + jv <- peekByteOff p j + if (jv <= pivot) + then do + when (i /= j) $ do + -- swap values + iv <- peekByteOff p i :: IO Word8 + pokeByteOff p j iv + pokeByteOff p i jv + go (i+1) (j+1) + else + go i (j+1) + go low low + +isValidUtf8BA :: ByteArray# -> Int -> IO Bool +isValidUtf8BA !ba !len' = isValidUtf8' (indexWord8Array# ba) len' + +isValidUtf8 :: Ptr Word8 -> Int -> IO Bool +isValidUtf8 !(Ptr a) !len' = isValidUtf8' (indexWord8OffAddr# a) len' + +isValidUtf8' :: (Int# -> Word8#) -> Int -> IO Bool +isValidUtf8' idx !len = go 0 + where + indexWord8 (I# i) = W8# (idx i) + + indexIsCont :: Int -> Bool + indexIsCont i = + -- We use a signed comparison to avoid an extra comparison with 0x80, + -- since _signed_ 0x80 is -128. + let + v :: Int8 + v = fromIntegral (indexWord8 i) + in v <= (fromIntegral (0xBF :: Word8)) + + go !i + | i >= len = pure True -- done + | otherwise = do + let !b0 = indexWord8 i + if | b0 <= 0x7F -> go (i+1) -- ASCII + | b0 >= 0xC2 && b0 <= 0xDF -> go2 (i+1) + | b0 >= 0xE0 && b0 <= 0xEF -> go3 (i+1) b0 + | otherwise -> go4 (i+1) b0 + + go2 !i + | i >= len = pure False + | indexIsCont i + = go (i+1) + | otherwise + = pure False + + go3 !i !b0 + | i >= len - 1 = pure False -- Be careful: i+1 might overflow! + | indexIsCont i + , indexIsCont (i+1) + , b1 <- indexWord8 i + , (b0 == 0xE0 && b1 >= 0xA0) -- E0, A0..BF, 80..BF + || (b0 >= 0xE1 && b0 <= 0xEC) -- E1..EC, 80..BF, 80..BF + || (b0 == 0xED && b1 <= 0x9F) -- ED, 80..9F, 80..BF + || (b0 >= 0xEE && b0 <= 0xEF) -- EE..EF, 80..BF, 80..BF + = go (i+2) + | otherwise + = pure False + + go4 !i !b0 + | i >= len - 2 = pure False -- Be careful: i+2 might overflow! + | indexIsCont i + , indexIsCont (i+1) + , indexIsCont (i+2) + , b1 <- indexWord8 i + , (b0 == 0xF0 && b1 >= 0x90) -- F0, 90..BF, 80..BF, 80..BF + || (b0 >= 0xF1 && b0 <= 0xF3) -- F1..F3, 80..BF, 80..BF, 80..BF + || (b0 == 0xF4 && b1 <= 0x8F) -- F4, 80..8F, 80..BF, 80..BF + = go (i+3) + + | otherwise + = pure False + + +---------------------------------------------------------------- +-- Haskell versions of functions in itoa.c +---------------------------------------------------------------- + + +getDigit :: Int -> Word8 +getDigit (I# i) = W8# (indexWord8OffAddr# digits i) + where + !digits = "0123456789abcdef"# + +putDigit :: Ptr a -> Int -> Int -> IO () +putDigit !addr !off !i = pokeByteOff addr off (getDigit i) + +-- | Reverse bytes in the given memory range (inclusive) +reverseBytesInplace :: Ptr Word8 -> Ptr Word8 -> IO () +reverseBytesInplace !p1 !p2 + | p1 < p2 = do + c1 <- peekByteOff p1 0 + c2 <- peekByteOff p2 0 + pokeByteOff p1 0 (c2 :: Word8) + pokeByteOff p2 0 (c1 :: Word8) + reverseBytesInplace (plusPtr p1 1) (plusPtr p2 (-1)) + | otherwise = pure () + +-- | Encode signed number as decimal +encodeSignedDec :: (Eq a, Num a, Integral a) => a -> Ptr Word8 -> IO (Ptr Word8) +{-# INLINABLE encodeSignedDec #-} -- for specialization +encodeSignedDec !x !buf + | x >= 0 = encodeUnsignedDec x buf + | otherwise = do + -- we cannot negate directly as 0 - (minBound :: Int) = minBound + -- So we write the sign and the first digit. + pokeByteOff buf 0 '-' + let !(q,r) = quotRem x (-10) + putDigit buf 1 (fromIntegral (abs r)) + case q of + 0 -> pure (plusPtr buf 2) + _ -> encodeUnsignedDec' q (plusPtr buf 1) (plusPtr buf 2) + + +-- | Encode positive number as decimal +encodeUnsignedDec :: (Eq a, Num a, Integral a) => a -> Ptr Word8 -> IO (Ptr Word8) +{-# INLINABLE encodeUnsignedDec #-} -- for specialization +encodeUnsignedDec !v !next_ptr = encodeUnsignedDec' v next_ptr next_ptr + +-- | Encode positive number as little-endian decimal, then reverse it. +-- +-- Take two pointers (orig_ptr, next_ptr) to support already encoded digits +-- (e.g. used by encodeSignedDec to avoid overflows) +-- +encodeUnsignedDec' :: (Eq a, Num a, Integral a) => a -> Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8) +{-# INLINABLE encodeUnsignedDec' #-} -- for specialization +encodeUnsignedDec' !v !orig_ptr !next_ptr = do + let !(q,r) = divMod v 10 + putDigit next_ptr 0 (fromIntegral r) + case q of + 0 -> do + -- reverse written digits + reverseBytesInplace orig_ptr next_ptr + -- return pointer after our digits + pure (plusPtr next_ptr 1) + _ -> encodeUnsignedDec' q orig_ptr (plusPtr next_ptr 1) + +encodeUnsignedDecPadded :: (Eq a, Num a, Integral a) => Int -> a -> Ptr Word8 -> IO () +{-# INLINABLE encodeUnsignedDecPadded #-} -- for specialization +encodeUnsignedDecPadded !max_width !v !buf = assert (max_width > 0) $ do + let !(q,r) = divMod v 10 + putDigit buf (max_width - 1) (fromIntegral r) + case q of + 0 -> do + -- pad beginning + let pad 0 = pure () + pad n = putDigit buf (n - 1) 0 >> pad (n - 1) + pad (max_width - 1) + _ -> encodeUnsignedDecPadded (max_width - 1) q buf + + + +-- | Encode positive number as hexadecimal +encodeUnsignedHex :: (Eq a, Num a, Integral a, Bits a) => a -> Ptr Word8 -> IO (Ptr Word8) +{-# INLINABLE encodeUnsignedHex #-} -- for specialization +encodeUnsignedHex !v !next_ptr = encodeUnsignedHex' v next_ptr next_ptr + +-- | Encode positive number as little-endian hexdecimal, then reverse it. +-- +-- Take two pointers (orig_ptr, next_ptr) to support already encoded digits +encodeUnsignedHex' :: (Eq a, Num a, Integral a, Bits a) => a -> Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8) +{-# INLINABLE encodeUnsignedHex' #-} -- for specialization +encodeUnsignedHex' !v !orig_ptr !next_ptr = do + -- (q,r) = divMod v 16, but faster + let !q = v `shiftR` 4 + let !r = v .&. 0x0F + putDigit next_ptr 0 (fromIntegral r) + case q of + 0 -> do + -- reverse written digits + reverseBytesInplace orig_ptr next_ptr + -- return pointer after our digits + pure (plusPtr next_ptr 1) + _ -> encodeUnsignedHex' q orig_ptr (plusPtr next_ptr 1) + + +lower_hex_table :: Ptr Word16 +lower_hex_table = Ptr + "000102030405060708090a0b0c0d0e0f\ + \101112131415161718191a1b1c1d1e1f\ + \202122232425262728292a2b2c2d2e2f\ + \303132333435363738393a3b3c3d3e3f\ + \404142434445464748494a4b4c4d4e4f\ + \505152535455565758595a5b5c5d5e5f\ + \606162636465666768696a6b6c6d6e6f\ + \707172737475767778797a7b7c7d7e7f\ + \808182838485868788898a8b8c8d8e8f\ + \909192939495969798999a9b9c9d9e9f\ + \a0a1a2a3a4a5a6a7a8a9aaabacadaeaf\ + \b0b1b2b3b4b5b6b7b8b9babbbcbdbebf\ + \c0c1c2c3c4c5c6c7c8c9cacbcccdcecf\ + \d0d1d2d3d4d5d6d7d8d9dadbdcdddedf\ + \e0e1e2e3e4e5e6e7e8e9eaebecedeeef\ + \f0f1f2f3f4f5f6f7f8f9fafbfcfdfeff"# + +digit_pairs_table :: Ptr Word16 +digit_pairs_table = Ptr + "00010203040506070809\ + \10111213141516171819\ + \20212223242526272829\ + \30313233343536373839\ + \40414243444546474849\ + \50515253545556575859\ + \60616263646566676869\ + \70717273747576777879\ + \80818283848586878889\ + \90919293949596979899"# diff --git a/Data/ByteString/Internal/Type.hs b/Data/ByteString/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Internal/Type.hs @@ -0,0 +1,1298 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Unsafe #-} + +{-# OPTIONS_HADDOCK not-home #-} + +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE ViewPatterns #-} + +#include "bytestring-cpp-macros.h" + +-- | +-- Module : Data.ByteString.Internal.Type +-- Copyright : (c) Don Stewart 2006-2008 +-- (c) Duncan Coutts 2006-2012 +-- License : BSD-style +-- Maintainer : dons00@gmail.com, duncan@community.haskell.org +-- Stability : unstable +-- Portability : non-portable +-- +-- The 'ByteString' type, its instances, and whatever related +-- utilities the bytestring developers see fit to use internally. +-- +module Data.ByteString.Internal.Type ( + + -- * The @ByteString@ type and representation + ByteString + ( BS + , PS -- backwards compatibility shim + ), + + StrictByteString, + + -- * Internal indexing + findIndexOrLength, + + -- * Conversion with lists: packing and unpacking + packBytes, packUptoLenBytes, unsafePackLenBytes, + packChars, packUptoLenChars, unsafePackLenChars, + unpackBytes, unpackAppendBytesLazy, unpackAppendBytesStrict, + unpackChars, unpackAppendCharsLazy, unpackAppendCharsStrict, + unsafePackAddress, unsafePackLenAddress, + unsafePackLiteral, unsafePackLenLiteral, + + -- * Low level imperative construction + empty, + createFp, + createFpUptoN, + createFpUptoN', + createFpAndTrim, + createFpAndTrim', + unsafeCreateFp, + unsafeCreateFpUptoN, + unsafeCreateFpUptoN', + create, + createUptoN, + createUptoN', + createAndTrim, + createAndTrim', + unsafeCreate, + unsafeCreateUptoN, + unsafeCreateUptoN', + mallocByteString, + + -- * Conversion to and from ForeignPtrs + mkDeferredByteString, + fromForeignPtr, + toForeignPtr, + fromForeignPtr0, + toForeignPtr0, + + -- * Utilities + nullForeignPtr, + peekFp, + pokeFp, + peekFpByteOff, + pokeFpByteOff, + minusForeignPtr, + memcpyFp, + deferForeignPtrAvailability, + unsafeDupablePerformIO, + SizeOverflowException, + overflowError, + checkedAdd, + checkedMultiply, + + -- * Standard C Functions + c_strlen, + c_free_finalizer, + + memchr, + memcmp, + memcpy, + memset, + + -- * cbits functions + c_reverse, + c_intersperse, + c_maximum, + c_minimum, + c_count, + c_count_ba, + c_elem_index, + c_sort, + c_int_dec, + c_int_dec_padded9, + c_uint_dec, + c_uint_hex, + c_long_long_int_dec, + c_long_long_int_dec_padded18, + c_long_long_uint_dec, + c_long_long_uint_hex, + cIsValidUtf8BA, + cIsValidUtf8BASafe, + cIsValidUtf8, + cIsValidUtf8Safe, + + -- * Chars + w2c, c2w, isSpaceWord8, isSpaceChar8, + + -- * Deprecated and unmentionable + accursedUnutterablePerformIO, + + -- * Exported compatibility shim + plusForeignPtr, + unsafeWithForeignPtr + ) where + +import Prelude hiding (concat, null) +import qualified Data.List as List + +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr +import Foreign.Storable (Storable(..)) +import Foreign.C.Types +import Foreign.C.String (CString) +import Foreign.Marshal.Utils +import Foreign.Marshal.Alloc (finalizerFree) + +#if PURE_HASKELL +import qualified Data.ByteString.Internal.Pure as Pure +import Data.Bits (toIntegralSized, Bits) +import Data.Maybe (fromMaybe) +import Control.Monad ((<$!>)) +#endif + +import Data.Semigroup (Semigroup (..)) +import Data.List.NonEmpty (NonEmpty ((:|))) + +import Control.DeepSeq (NFData(rnf)) + +import Data.String (IsString(..)) + +import Control.Exception (assert, throw, Exception) + +import Data.Bits ((.&.)) +import Data.Char (ord) +import Data.Word + +import Data.Data (Data(..), mkConstr, mkNoRepType, Constr, DataType, Fixity(Prefix), constrIndex) + +import GHC.Base (nullAddr#,realWorld#,unsafeChr,unpackCString#) +import GHC.Exts (IsList(..), Addr#, minusAddr#, ByteArray#, runRW#, lazy) + +#if HS_timesInt2_PRIMOP_AVAILABLE +import GHC.Exts (timesInt2#) +#else +import GHC.Exts ( timesWord2# + , or# + , uncheckedShiftRL# + , int2Word# + , word2Int# + ) +import Data.Bits (finiteBitSize) +#endif + +import GHC.IO (IO(IO)) +import GHC.ForeignPtr (ForeignPtr(ForeignPtr) +#if !HS_cstringLength_AND_FinalPtr_AVAILABLE + , newForeignPtr_ +#endif + , mallocPlainForeignPtrBytes) + +import GHC.ForeignPtr (plusForeignPtr) + +#if HS_cstringLength_AND_FinalPtr_AVAILABLE +import GHC.Exts (cstringLength#) +import GHC.ForeignPtr (ForeignPtrContents(FinalPtr)) +#else +import GHC.Ptr (Ptr(..)) +#endif + +import GHC.Int (Int (..)) + +#if HS_unsafeWithForeignPtr_AVAILABLE +import GHC.ForeignPtr (unsafeWithForeignPtr) +#endif + +import qualified Language.Haskell.TH.Lib as TH +import qualified Language.Haskell.TH.Syntax as TH + +#if !HS_unsafeWithForeignPtr_AVAILABLE +unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b +unsafeWithForeignPtr = withForeignPtr +#endif + +-- CFILES stuff is Hugs only +{-# CFILES cbits/fpstring.c #-} + +minusForeignPtr :: ForeignPtr a -> ForeignPtr b -> Int +minusForeignPtr (ForeignPtr addr1 _) (ForeignPtr addr2 _) + = I# (minusAddr# addr1 addr2) + +peekFp :: Storable a => ForeignPtr a -> IO a +peekFp fp = unsafeWithForeignPtr fp peek + +pokeFp :: Storable a => ForeignPtr a -> a -> IO () +pokeFp fp val = unsafeWithForeignPtr fp $ \p -> poke p val + +peekFpByteOff :: Storable a => ForeignPtr a -> Int -> IO a +peekFpByteOff fp off = unsafeWithForeignPtr fp $ \p -> + peekByteOff p off + +pokeFpByteOff :: Storable a => ForeignPtr b -> Int -> a -> IO () +pokeFpByteOff fp off val = unsafeWithForeignPtr fp $ \p -> + pokeByteOff p off val + +-- | Most operations on a 'ByteString' need to read from the buffer +-- given by its @ForeignPtr Word8@ field. But since most operations +-- on @ByteString@ are (nominally) pure, their implementations cannot +-- see the IO state thread that was used to initialize the contents of +-- that buffer. This means that under some circumstances, these +-- buffer-reads may be executed before the writes used to initialize +-- the buffer are executed, with unpredictable results. +-- +-- 'deferForeignPtrAvailability' exists to help solve this problem. +-- At runtime, a call @'deferForeignPtrAvailability' x@ is equivalent +-- to @pure $! x@, but the former is more opaque to the simplifier, so +-- that reads from the pointer in its result cannot be executed until +-- the @'deferForeignPtrAvailability' x@ call is complete. +-- +-- The opaque bits evaporate during CorePrep, so using +-- 'deferForeignPtrAvailability' incurs no direct overhead. +-- +-- @since 0.11.5.0 +deferForeignPtrAvailability :: ForeignPtr a -> IO (ForeignPtr a) +deferForeignPtrAvailability (ForeignPtr addr0# guts) = IO $ \s0 -> + case lazy runRW# (\_ -> (# s0, addr0# #)) of + (# s1, addr1# #) -> (# s1, ForeignPtr addr1# guts #) + +-- | Variant of 'fromForeignPtr0' that calls 'deferForeignPtrAvailability' +-- +-- @since 0.11.5.0 +mkDeferredByteString :: ForeignPtr Word8 -> Int -> IO ByteString +mkDeferredByteString fp len = do + deferredFp <- deferForeignPtrAvailability fp + pure $! BS deferredFp len + +unsafeDupablePerformIO :: IO a -> a +-- Why does this exist? In base-4.15.1.0 until at least base-4.18.0.0, +-- the version of unsafeDupablePerformIO in base prevents unboxing of +-- its results with an opaque call to GHC.Exts.lazy, for reasons described +-- in Note [unsafePerformIO and strictness] in GHC.IO.Unsafe. (See +-- https://hackage.haskell.org/package/base-4.18.0.0/docs/src/GHC.IO.Unsafe.html#line-30 .) +-- Even if we accept the (very questionable) premise that the sort of +-- function described in that note should work, we expect no such +-- calls to be made in the context of bytestring. (And we really want +-- unboxing!) +unsafeDupablePerformIO (IO act) = case runRW# act of (# _, res #) -> res + + + +-- ----------------------------------------------------------------------------- + +-- | A space-efficient representation of a 'Word8' vector, supporting many +-- efficient operations. +-- +-- A 'ByteString' contains 8-bit bytes, or by using the operations from +-- "Data.ByteString.Char8" it can be interpreted as containing 8-bit +-- characters. +-- +data ByteString = BS {-# UNPACK #-} !(ForeignPtr Word8) -- payload + {-# UNPACK #-} !Int -- length + -- ^ @since 0.11.0.0 + +-- | Type synonym for the strict flavour of 'ByteString'. +-- +-- @since 0.11.2.0 +type StrictByteString = ByteString + +-- | +-- @'PS' foreignPtr offset length@ represents a 'ByteString' with data +-- backed by a given @foreignPtr@, starting at a given @offset@ in bytes +-- and of a specified @length@. +-- +-- This pattern is used to emulate the legacy 'ByteString' data +-- constructor, so that pre-existing code generally doesn't need to +-- change to benefit from the simplified 'BS' constructor and can +-- continue to function unchanged. +-- +-- /Note:/ Matching with this constructor will always be given a 0 offset, +-- as the base will be manipulated by 'plusForeignPtr' instead. +-- +pattern PS :: ForeignPtr Word8 -> Int -> Int -> ByteString +pattern PS fp zero len <- BS fp ((0,) -> (zero, len)) where + PS fp o len = BS (plusForeignPtr fp o) len +{-# COMPLETE PS #-} + +instance Eq ByteString where + (==) = eq + +instance Ord ByteString where + compare = compareBytes + +instance Semigroup ByteString where + (<>) = append + sconcat (b:|bs) = concat (b:bs) + {-# INLINE stimes #-} + stimes = stimesPolymorphic + +instance Monoid ByteString where + mempty = empty + mappend = (<>) + mconcat = concat + +instance NFData ByteString where + rnf BS{} = () + +instance Show ByteString where + showsPrec p ps r = showsPrec p (unpackChars ps) r + +instance Read ByteString where + readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ] + +-- | @since 0.10.12.0 +instance IsList ByteString where + type Item ByteString = Word8 + fromList = packBytes + toList = unpackBytes + +-- | Beware: 'fromString' truncates multi-byte characters to octets. +-- e.g. "枯朶に烏のとまりけり秋の暮" becomes �6k�nh~�Q��n� +instance IsString ByteString where + {-# INLINE fromString #-} + fromString = packChars + +instance Data ByteString where + gfoldl f z txt = z packBytes `f` unpackBytes txt + toConstr _ = packConstr + gunfold k z c = case constrIndex c of + 1 -> k (z packBytes) + _ -> error "gunfold: unexpected constructor of strict ByteString" + dataTypeOf _ = byteStringDataType + +packConstr :: Constr +packConstr = mkConstr byteStringDataType "pack" [] Prefix + +byteStringDataType :: DataType +byteStringDataType = mkNoRepType "Data.ByteString.ByteString" + +-- | @since 0.11.2.0 +instance TH.Lift ByteString where +#if MIN_VERSION_template_haskell(2,16,0) +-- template-haskell-2.16 first ships with ghc-8.10 + lift (BS ptr len) = [| unsafePackLenLiteral |] + `TH.appE` TH.litE (TH.integerL (fromIntegral len)) + `TH.appE` TH.litE (TH.BytesPrimL $ TH.Bytes ptr 0 (fromIntegral len)) +#else + lift bs@(BS _ len) = [| unsafePackLenLiteral |] + `TH.appE` TH.litE (TH.integerL (fromIntegral len)) + `TH.appE` TH.litE (TH.StringPrimL $ unpackBytes bs) +#endif + +#if MIN_VERSION_template_haskell(2,17,0) +-- template-haskell-2.17 first ships with ghc-9.0 + liftTyped = TH.unsafeCodeCoerce . TH.lift +#elif MIN_VERSION_template_haskell(2,16,0) +-- template-haskell-2.16 first ships with ghc-8.10 + liftTyped = TH.unsafeTExpCoerce . TH.lift +#endif + +------------------------------------------------------------------------ +-- Internal indexing + +-- | 'findIndexOrLength' is a variant of findIndex, that returns the length +-- of the string if no element is found, rather than Nothing. +findIndexOrLength :: (Word8 -> Bool) -> ByteString -> Int +findIndexOrLength k (BS x l) = + accursedUnutterablePerformIO $ g x + where + g ptr = go 0 + where + go !n | n >= l = return l + | otherwise = do w <- peekFp $ ptr `plusForeignPtr` n + if k w + then return n + else go (n+1) +{-# INLINE findIndexOrLength #-} + +------------------------------------------------------------------------ +-- Packing and unpacking from lists + +packBytes :: [Word8] -> ByteString +packBytes ws = unsafePackLenBytes (List.length ws) ws + +packChars :: [Char] -> ByteString +packChars cs = unsafePackLenChars (List.length cs) cs + +{-# INLINE [0] packChars #-} + +{-# RULES +"ByteString packChars/packAddress" forall s . + packChars (unpackCString# s) = unsafePackLiteral s + #-} + +unsafePackLenBytes :: Int -> [Word8] -> ByteString +unsafePackLenBytes len xs0 = + unsafeCreateFp len $ \p -> go p xs0 + where + go !_ [] = return () + go !p (x:xs) = pokeFp p x >> go (p `plusForeignPtr` 1) xs + +unsafePackLenChars :: Int -> [Char] -> ByteString +unsafePackLenChars len cs0 = + unsafeCreateFp len $ \p -> go p cs0 + where + go !_ [] = return () + go !p (c:cs) = pokeFp p (c2w c) >> go (p `plusForeignPtr` 1) cs + + +-- | /O(n)/ Pack a null-terminated sequence of bytes, pointed to by an +-- Addr\# (an arbitrary machine address assumed to point outside the +-- garbage-collected heap) into a @ByteString@. A much faster way to +-- create an 'Addr#' is with an unboxed string literal, than to pack a +-- boxed string. A unboxed string literal is compiled to a static @char +-- []@ by GHC. Establishing the length of the string requires a call to +-- @strlen(3)@, so the 'Addr#' must point to a null-terminated buffer (as +-- is the case with @\"string\"\#@ literals in GHC). Use 'Data.ByteString.Unsafe.unsafePackAddressLen' +-- if you know the length of the string statically. +-- +-- An example: +-- +-- > literalFS = unsafePackAddress "literal"# +-- +-- This function is /unsafe/. If you modify the buffer pointed to by the +-- original 'Addr#' this modification will be reflected in the resulting +-- @ByteString@, breaking referential transparency. +-- +-- Note this also won't work if your 'Addr#' has embedded @\'\\0\'@ characters in +-- the string, as @strlen@ will return too short a length. +-- +unsafePackAddress :: Addr# -> IO ByteString +unsafePackAddress addr# = do +#if HS_cstringLength_AND_FinalPtr_AVAILABLE + unsafePackLenAddress (I# (cstringLength# addr#)) addr# +#else + l <- c_strlen (Ptr addr#) + unsafePackLenAddress (fromIntegral l) addr# +#endif +{-# INLINE unsafePackAddress #-} + +-- | See 'unsafePackAddress'. This function is similar, +-- but takes an additional length argument rather then computing +-- it with @strlen@. +-- Therefore embedding @\'\\0\'@ characters is possible. +-- +-- @since 0.11.2.0 +unsafePackLenAddress :: Int -> Addr# -> IO ByteString +unsafePackLenAddress len addr# = do +#if HS_cstringLength_AND_FinalPtr_AVAILABLE + return (BS (ForeignPtr addr# FinalPtr) len) +#else + p <- newForeignPtr_ (Ptr addr#) + return $ BS p len +#endif +{-# INLINE unsafePackLenAddress #-} + +-- | See 'unsafePackAddress'. This function has similar behavior. Prefer +-- this function when the address in known to be an @Addr#@ literal. In +-- that context, there is no need for the sequencing guarantees that 'IO' +-- provides. On GHC 9.0 and up, this function uses the @FinalPtr@ data +-- constructor for @ForeignPtrContents@. +-- +-- @since 0.11.1.0 +unsafePackLiteral :: Addr# -> ByteString +unsafePackLiteral addr# = +#if HS_cstringLength_AND_FinalPtr_AVAILABLE + unsafePackLenLiteral (I# (cstringLength# addr#)) addr# +#else + let len = accursedUnutterablePerformIO (c_strlen (Ptr addr#)) + in unsafePackLenLiteral (fromIntegral len) addr# +#endif +{-# INLINE unsafePackLiteral #-} + + +-- | See 'unsafePackLiteral'. This function is similar, +-- but takes an additional length argument rather then computing +-- it with @strlen@. +-- Therefore embedding @\'\\0\'@ characters is possible. +-- +-- @since 0.11.2.0 +unsafePackLenLiteral :: Int -> Addr# -> ByteString +unsafePackLenLiteral len addr# = +#if HS_cstringLength_AND_FinalPtr_AVAILABLE + BS (ForeignPtr addr# FinalPtr) len +#else + -- newForeignPtr_ allocates a MutVar# internally. If that MutVar# + -- gets commoned up with the MutVar# of some unrelated ForeignPtr, + -- it may prevent automatic finalization for that other ForeignPtr. + -- So we avoid accursedUnutterablePerformIO here. + BS (unsafeDupablePerformIO (newForeignPtr_ (Ptr addr#))) len +#endif +{-# INLINE unsafePackLenLiteral #-} + +packUptoLenBytes :: Int -> [Word8] -> (ByteString, [Word8]) +packUptoLenBytes len xs0 = + unsafeCreateFpUptoN' len $ \p0 -> + let p_end = plusForeignPtr p0 len + go !p [] = return (p `minusForeignPtr` p0, []) + go !p xs | p == p_end = return (len, xs) + go !p (x:xs) = pokeFp p x >> go (p `plusForeignPtr` 1) xs + in go p0 xs0 + +packUptoLenChars :: Int -> [Char] -> (ByteString, [Char]) +packUptoLenChars len cs0 = + unsafeCreateFpUptoN' len $ \p0 -> + let p_end = plusForeignPtr p0 len + go !p [] = return (p `minusForeignPtr` p0, []) + go !p cs | p == p_end = return (len, cs) + go !p (c:cs) = pokeFp p (c2w c) >> go (p `plusForeignPtr` 1) cs + in go p0 cs0 + +-- Unpacking bytestrings into lists efficiently is a tradeoff: on the one hand +-- we would like to write a tight loop that just blasts the list into memory, on +-- the other hand we want it to be unpacked lazily so we don't end up with a +-- massive list data structure in memory. +-- +-- Our strategy is to combine both: we will unpack lazily in reasonable sized +-- chunks, where each chunk is unpacked strictly. +-- +-- unpackBytes and unpackChars do the lazy loop, while unpackAppendBytes and +-- unpackAppendChars do the chunks strictly. + +unpackBytes :: ByteString -> [Word8] +unpackBytes bs = unpackAppendBytesLazy bs [] + +unpackChars :: ByteString -> [Char] +unpackChars bs = unpackAppendCharsLazy bs [] + +unpackAppendBytesLazy :: ByteString -> [Word8] -> [Word8] +unpackAppendBytesLazy (BS fp len) xs + | len <= 100 = unpackAppendBytesStrict (BS fp len) xs + | otherwise = unpackAppendBytesStrict (BS fp 100) remainder + where + remainder = unpackAppendBytesLazy (BS (plusForeignPtr fp 100) (len-100)) xs + + -- Why 100 bytes you ask? Because on a 64bit machine the list we allocate + -- takes just shy of 4k which seems like a reasonable amount. + -- (5 words per list element, 8 bytes per word, 100 elements = 4000 bytes) + +unpackAppendCharsLazy :: ByteString -> [Char] -> [Char] +unpackAppendCharsLazy (BS fp len) cs + | len <= 100 = unpackAppendCharsStrict (BS fp len) cs + | otherwise = unpackAppendCharsStrict (BS fp 100) remainder + where + remainder = unpackAppendCharsLazy (BS (plusForeignPtr fp 100) (len-100)) cs + +-- For these unpack functions, since we're unpacking the whole list strictly we +-- build up the result list in an accumulator. This means we have to build up +-- the list starting at the end. So our traversal starts at the end of the +-- buffer and loops down until we hit the sentinal: + +unpackAppendBytesStrict :: ByteString -> [Word8] -> [Word8] +unpackAppendBytesStrict (BS fp len) xs = + accursedUnutterablePerformIO $ unsafeWithForeignPtr fp $ \base -> + loop (base `plusPtr` (-1)) (base `plusPtr` (-1+len)) xs + where + loop !sentinal !p acc + | p == sentinal = return acc + | otherwise = do x <- peek p + loop sentinal (p `plusPtr` (-1)) (x:acc) + +unpackAppendCharsStrict :: ByteString -> [Char] -> [Char] +unpackAppendCharsStrict (BS fp len) xs = + accursedUnutterablePerformIO $ unsafeWithForeignPtr fp $ \base -> + loop (base `plusPtr` (-1)) (base `plusPtr` (-1+len)) xs + where + loop !sentinal !p acc + | p == sentinal = return acc + | otherwise = do x <- peek p + loop sentinal (p `plusPtr` (-1)) (w2c x:acc) + +------------------------------------------------------------------------ + +-- | The 0 pointer. Used to indicate the empty Bytestring. +nullForeignPtr :: ForeignPtr Word8 +#if HS_cstringLength_AND_FinalPtr_AVAILABLE +nullForeignPtr = ForeignPtr nullAddr# FinalPtr +#else +nullForeignPtr = ForeignPtr nullAddr# (error "nullForeignPtr") +#endif + +-- --------------------------------------------------------------------- +-- Low level constructors + +-- | /O(1)/ Build a ByteString from a ForeignPtr. +-- +-- If you do not need the offset parameter then you should be using +-- 'Data.ByteString.Unsafe.unsafePackCStringLen' or +-- 'Data.ByteString.Unsafe.unsafePackCStringFinalizer' instead. +-- +fromForeignPtr :: ForeignPtr Word8 + -> Int -- ^ Offset + -> Int -- ^ Length + -> ByteString +fromForeignPtr fp o = BS (plusForeignPtr fp o) +{-# INLINE fromForeignPtr #-} + +-- | @since 0.11.0.0 +fromForeignPtr0 :: ForeignPtr Word8 + -> Int -- ^ Length + -> ByteString +fromForeignPtr0 = BS +{-# INLINE fromForeignPtr0 #-} + +-- | /O(1)/ Deconstruct a ForeignPtr from a ByteString +toForeignPtr :: ByteString -> (ForeignPtr Word8, Int, Int) -- ^ (ptr, offset, length) +toForeignPtr (BS ps l) = (ps, 0, l) +{-# INLINE toForeignPtr #-} + +-- | /O(1)/ Deconstruct a ForeignPtr from a ByteString +-- +-- @since 0.11.0.0 +toForeignPtr0 :: ByteString -> (ForeignPtr Word8, Int) -- ^ (ptr, length) +toForeignPtr0 (BS ps l) = (ps, l) +{-# INLINE toForeignPtr0 #-} + +-- | A way of creating ByteStrings outside the IO monad. The @Int@ +-- argument gives the final size of the ByteString. +unsafeCreateFp :: Int -> (ForeignPtr Word8 -> IO ()) -> ByteString +unsafeCreateFp l f = unsafeDupablePerformIO (createFp l f) +{-# INLINE unsafeCreateFp #-} + +-- | Like 'unsafeCreateFp' but instead of giving the final size of the +-- ByteString, it is just an upper bound. The inner action returns +-- the actual size. Unlike 'createFpAndTrim' the ByteString is not +-- reallocated if the final size is less than the estimated size. +unsafeCreateFpUptoN :: Int -> (ForeignPtr Word8 -> IO Int) -> ByteString +unsafeCreateFpUptoN l f = unsafeDupablePerformIO (createFpUptoN l f) +{-# INLINE unsafeCreateFpUptoN #-} + +unsafeCreateFpUptoN' + :: Int -> (ForeignPtr Word8 -> IO (Int, a)) -> (ByteString, a) +unsafeCreateFpUptoN' l f = unsafeDupablePerformIO (createFpUptoN' l f) +{-# INLINE unsafeCreateFpUptoN' #-} + +-- | Create ByteString of size @l@ and use action @f@ to fill its contents. +createFp :: Int -> (ForeignPtr Word8 -> IO ()) -> IO ByteString +createFp len action = assert (len >= 0) $ do + fp <- mallocByteString len + action fp + mkDeferredByteString fp len +{-# INLINE createFp #-} + +-- | Given a maximum size @l@ and an action @f@ that fills the 'ByteString' +-- starting at the given 'Ptr' and returns the actual utilized length, +-- @`createFpUptoN'` l f@ returns the filled 'ByteString'. +createFpUptoN :: Int -> (ForeignPtr Word8 -> IO Int) -> IO ByteString +createFpUptoN maxLen action = assert (maxLen >= 0) $ do + fp <- mallocByteString maxLen + len <- action fp + assert (0 <= len && len <= maxLen) $ mkDeferredByteString fp len +{-# INLINE createFpUptoN #-} + +-- | Like 'createFpUptoN', but also returns an additional value created by the +-- action. +createFpUptoN' :: Int -> (ForeignPtr Word8 -> IO (Int, a)) -> IO (ByteString, a) +createFpUptoN' maxLen action = assert (maxLen >= 0) $ do + fp <- mallocByteString maxLen + (len, res) <- action fp + bs <- mkDeferredByteString fp len + assert (0 <= len && len <= maxLen) $ pure (bs, res) +{-# INLINE createFpUptoN' #-} + +-- | Given the maximum size needed and a function to make the contents +-- of a ByteString, createFpAndTrim makes the 'ByteString'. The generating +-- function is required to return the actual final size (<= the maximum +-- size), and the resulting byte array is reallocated to this size. +-- +-- createFpAndTrim is the main mechanism for creating custom, efficient +-- ByteString functions, using Haskell or C functions to fill the space. +-- +createFpAndTrim :: Int -> (ForeignPtr Word8 -> IO Int) -> IO ByteString +createFpAndTrim maxLen action = assert (maxLen >= 0) $ do + fp <- mallocByteString maxLen + len <- action fp + if assert (0 <= len && len <= maxLen) $ len >= maxLen + then mkDeferredByteString fp maxLen + else createFp len $ \dest -> memcpyFp dest fp len +{-# INLINE createFpAndTrim #-} + +createFpAndTrim' :: Int -> (ForeignPtr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a) +createFpAndTrim' maxLen action = assert (maxLen >= 0) $ do + fp <- mallocByteString maxLen + (off, len, res) <- action fp + assert ( + 0 <= len && len <= maxLen && -- length OK + (len == 0 || (0 <= off && off <= maxLen - len)) -- offset OK + ) $ pure () + bs <- if len >= maxLen + then mkDeferredByteString fp maxLen -- entire buffer used => offset is zero + else createFp len $ \dest -> + memcpyFp dest (fp `plusForeignPtr` off) len + return (bs, res) +{-# INLINE createFpAndTrim' #-} + + +wrapAction :: (Ptr Word8 -> IO res) -> ForeignPtr Word8 -> IO res +wrapAction = flip withForeignPtr + -- Cannot use unsafeWithForeignPtr, because action can diverge + +-- | A way of creating ByteStrings outside the IO monad. The @Int@ +-- argument gives the final size of the ByteString. +unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> ByteString +unsafeCreate l f = unsafeCreateFp l (wrapAction f) +{-# INLINE unsafeCreate #-} + +-- | Like 'unsafeCreate' but instead of giving the final size of the +-- ByteString, it is just an upper bound. The inner action returns +-- the actual size. Unlike 'createAndTrim' the ByteString is not +-- reallocated if the final size is less than the estimated size. +unsafeCreateUptoN :: Int -> (Ptr Word8 -> IO Int) -> ByteString +unsafeCreateUptoN l f = unsafeCreateFpUptoN l (wrapAction f) +{-# INLINE unsafeCreateUptoN #-} + +-- | @since 0.10.12.0 +unsafeCreateUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> (ByteString, a) +unsafeCreateUptoN' l f = unsafeCreateFpUptoN' l (wrapAction f) +{-# INLINE unsafeCreateUptoN' #-} + +-- | Create ByteString of size @l@ and use action @f@ to fill its contents. +create :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString +create l action = createFp l (wrapAction action) +{-# INLINE create #-} + +-- | Given a maximum size @l@ and an action @f@ that fills the 'ByteString' +-- starting at the given 'Ptr' and returns the actual utilized length, +-- @`createUptoN'` l f@ returns the filled 'ByteString'. +createUptoN :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString +createUptoN l action = createFpUptoN l (wrapAction action) +{-# INLINE createUptoN #-} + +-- | Like 'createUptoN', but also returns an additional value created by the +-- action. +-- +-- @since 0.10.12.0 +createUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> IO (ByteString, a) +createUptoN' l action = createFpUptoN' l (wrapAction action) +{-# INLINE createUptoN' #-} + +-- | Given the maximum size needed and a function to make the contents +-- of a ByteString, createAndTrim makes the 'ByteString'. The generating +-- function is required to return the actual final size (<= the maximum +-- size), and the resulting byte array is reallocated to this size. +-- +-- createAndTrim is the main mechanism for creating custom, efficient +-- ByteString functions, using Haskell or C functions to fill the space. +-- +createAndTrim :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString +createAndTrim l action = createFpAndTrim l (wrapAction action) +{-# INLINE createAndTrim #-} + +createAndTrim' :: Int -> (Ptr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a) +createAndTrim' l action = createFpAndTrim' l (wrapAction action) +{-# INLINE createAndTrim' #-} + + +-- | Wrapper of 'Foreign.ForeignPtr.mallocForeignPtrBytes' with faster implementation for GHC +-- +mallocByteString :: Int -> IO (ForeignPtr a) +mallocByteString = mallocPlainForeignPtrBytes +{-# INLINE mallocByteString #-} + +------------------------------------------------------------------------ +-- Implementations for Eq, Ord and Monoid instances + +eq :: ByteString -> ByteString -> Bool +eq a@(BS fp len) b@(BS fp' len') + | len /= len' = False -- short cut on length + | fp == fp' = True -- short cut for the same string + | otherwise = compareBytes a b == EQ +{-# INLINE eq #-} +-- ^ still needed + +compareBytes :: ByteString -> ByteString -> Ordering +compareBytes (BS _ 0) (BS _ 0) = EQ -- short cut for empty strings +compareBytes (BS fp1 len1) (BS fp2 len2) = + accursedUnutterablePerformIO $ + unsafeWithForeignPtr fp1 $ \p1 -> + unsafeWithForeignPtr fp2 $ \p2 -> do + i <- memcmp p1 p2 (min len1 len2) + return $! case i `compare` 0 of + EQ -> len1 `compare` len2 + x -> x + + +-- | /O(1)/ The empty 'ByteString' +empty :: ByteString +-- This enables bypassing #457 by not using (polymorphic) mempty in +-- any definitions used by the (Monoid ByteString) instance +empty = BS nullForeignPtr 0 + +append :: ByteString -> ByteString -> ByteString +append (BS _ 0) b = b +append a (BS _ 0) = a +append (BS fp1 len1) (BS fp2 len2) = + unsafeCreateFp (checkedAdd "append" len1 len2) $ \destptr1 -> do + let destptr2 = destptr1 `plusForeignPtr` len1 + memcpyFp destptr1 fp1 len1 + memcpyFp destptr2 fp2 len2 + +concat :: [ByteString] -> ByteString +concat = \bss0 -> goLen0 bss0 bss0 + -- The idea here is we first do a pass over the input list to determine: + -- + -- 1. is a copy necessary? e.g. @concat []@, @concat [mempty, "hello"]@, + -- and @concat ["hello", mempty, mempty]@ can all be handled without + -- copying. + -- 2. if a copy is necessary, how large is the result going to be? + -- + -- If a copy is necessary then we create a buffer of the appropriate size + -- and do another pass over the input list, copying the chunks into the + -- buffer. Also, since foreign calls aren't entirely free we skip over + -- empty chunks while copying. + -- + -- We pass the original [ByteString] (bss0) through as an argument through + -- goLen0, goLen1, and goLen since we will need it again in goCopy. Passing + -- it as an explicit argument avoids capturing it in these functions' + -- closures which would result in unnecessary closure allocation. + where + -- It's still possible that the result is empty + goLen0 _ [] = empty + goLen0 bss0 (BS _ 0 :bss) = goLen0 bss0 bss + goLen0 bss0 (bs :bss) = goLen1 bss0 bs bss + + -- It's still possible that the result is a single chunk + goLen1 _ bs [] = bs + goLen1 bss0 bs (BS _ 0 :bss) = goLen1 bss0 bs bss + goLen1 bss0 bs (BS _ len:bss) = goLen bss0 (checkedAdd "concat" len' len) bss + where BS _ len' = bs + + -- General case, just find the total length we'll need + goLen bss0 !total (BS _ len:bss) = goLen bss0 total' bss + where total' = checkedAdd "concat" total len + goLen bss0 total [] = + unsafeCreateFp total $ \ptr -> goCopy bss0 ptr + + -- Copy the data + goCopy [] !_ = return () + goCopy (BS _ 0 :bss) !ptr = goCopy bss ptr + goCopy (BS fp len:bss) !ptr = do + memcpyFp ptr fp len + goCopy bss (ptr `plusForeignPtr` len) +{-# NOINLINE concat #-} + +{-# RULES +"ByteString concat [] -> empty" + concat [] = empty +"ByteString concat [bs] -> bs" forall x. + concat [x] = x + #-} + +-- | Repeats the given ByteString n times. +-- Polymorphic wrapper to make sure any generated +-- specializations are reasonably small. +stimesPolymorphic :: Integral a => a -> ByteString -> ByteString +{-# INLINABLE stimesPolymorphic #-} +stimesPolymorphic nRaw !bs = case checkedIntegerToInt n of + Just nInt + | nInt >= 0 -> stimesNonNegativeInt nInt bs + | otherwise -> stimesNegativeErr + Nothing + | n < 0 -> stimesNegativeErr + | BS _ 0 <- bs -> empty + | otherwise -> stimesOverflowErr + where n = toInteger nRaw + -- By exclusively using n instead of nRaw, the semantics are kept simple + -- and the likelihood of potentially dangerous mistakes minimized. + + +{- +Note [Float error calls out of INLINABLE things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If a function is marked INLINE or INLINABLE, then when ghc inlines or +specializes it, it duplicates the function body exactly as written. + +This feature is useful for systems of rewrite rules, but sometimes +comes at a code-size cost. One situation where this cost generally +comes with no compensating up-side is when the function in question +calls `error` or something similar. + +Such an `error` call is not meaningfully improved by the extra context +inlining or specialization provides, and if inlining or specialization +happens in a different module from where the function was originally +defined, CSE will not be able to de-duplicate the error call floated +out of the inlined RHS and the error call floated out of the original +RHS. See also https://gitlab.haskell.org/ghc/ghc/-/issues/23823 + +To mitigate this, we manually float the error calls out of INLINABLE +functions when it is possible to do so. +-} + +stimesNegativeErr :: ByteString +-- See Note [Float error calls out of INLINABLE things] +stimesNegativeErr + = errorWithoutStackTrace "stimes @ByteString: non-negative multiplier expected" + +stimesOverflowErr :: ByteString +-- See Note [Float error calls out of INLINABLE things] +stimesOverflowErr = overflowError "stimes" + +-- | Repeats the given ByteString n times. +stimesNonNegativeInt :: Int -> ByteString -> ByteString +stimesNonNegativeInt n (BS fp len) + | n == 0 = empty + | n == 1 = BS fp len + | len == 0 = empty + | len == 1 = unsafeCreateFp n $ \destfptr -> do + byte <- peekFp fp + unsafeWithForeignPtr destfptr $ \destptr -> + fillBytes destptr byte n + | otherwise = unsafeCreateFp size $ \destptr -> do + memcpyFp destptr fp len + fillFrom destptr len + where + size = checkedMultiply "stimes" n len + halfSize = (size - 1) `div` 2 -- subtraction and division won't overflow + + fillFrom :: ForeignPtr Word8 -> Int -> IO () + fillFrom destptr copied + | copied <= halfSize = do + memcpyFp (destptr `plusForeignPtr` copied) destptr copied + fillFrom destptr (copied * 2) + | otherwise = memcpyFp (destptr `plusForeignPtr` copied) destptr (size - copied) + + +------------------------------------------------------------------------ + +-- | Conversion between 'Word8' and 'Char'. Should compile to a no-op. +w2c :: Word8 -> Char +w2c = unsafeChr . fromIntegral +{-# INLINE w2c #-} + +-- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and +-- silently truncates to 8 bits Chars > '\255'. It is provided as +-- convenience for ByteString construction. +c2w :: Char -> Word8 +c2w = fromIntegral . ord +{-# INLINE c2w #-} + +-- | Selects words corresponding to white-space characters in the Latin-1 range +isSpaceWord8 :: Word8 -> Bool +isSpaceWord8 w8 = + -- Avoid the cost of narrowing arithmetic results to Word8, + -- the conversion from Word8 to Word is free. + let w :: Word + !w = fromIntegral w8 + in w .&. 0x50 == 0 -- Quick non-whitespace filter + && w - 0x21 > 0x7e -- Second non-whitespace filter + && ( w == 0x20 -- SP + || w == 0xa0 -- NBSP + || w - 0x09 < 5) -- HT, NL, VT, FF, CR +{-# INLINE isSpaceWord8 #-} + +-- | Selects white-space characters in the Latin-1 range +isSpaceChar8 :: Char -> Bool +isSpaceChar8 = isSpaceWord8 . c2w +{-# INLINE isSpaceChar8 #-} + +------------------------------------------------------------------------ + +-- | The type of exception raised by 'overflowError' +-- and on failure by overflow-checked arithmetic operations. +newtype SizeOverflowException + = SizeOverflowException String + +instance Show SizeOverflowException where + show (SizeOverflowException err) = err + +instance Exception SizeOverflowException + +-- | Raises a 'SizeOverflowException', +-- with a message using the given function name. +overflowError :: String -> a +overflowError fun = throw $ SizeOverflowException msg + where msg = "Data.ByteString." ++ fun ++ ": size overflow" + +-- | Add two non-negative numbers. +-- Calls 'overflowError' on overflow. +checkedAdd :: String -> Int -> Int -> Int +{-# INLINE checkedAdd #-} +checkedAdd fun x y + -- checking "r < 0" here matches the condition in mallocPlainForeignPtrBytes, + -- helping the compiler see the latter is redundant in some places + | r < 0 = overflowError fun + | otherwise = r + where r = assert (min x y >= 0) $ x + y + +-- | Multiplies two non-negative numbers. +-- Calls 'overflowError' on overflow. +checkedMultiply :: String -> Int -> Int -> Int +{-# INLINE checkedMultiply #-} +checkedMultiply fun !x@(I# x#) !y@(I# y#) = assert (min x y >= 0) $ +#if HS_timesInt2_PRIMOP_AVAILABLE + case timesInt2# x# y# of + (# 0#, _, result #) -> I# result + _ -> overflowError fun +#else + case timesWord2# (int2Word# x#) (int2Word# y#) of + (# hi, lo #) -> case or# hi (uncheckedShiftRL# lo shiftAmt) of + 0## -> I# (word2Int# lo) + _ -> overflowError fun + where !(I# shiftAmt) = finiteBitSize (0 :: Word) - 1 +#endif + + +-- | Attempts to convert an 'Integer' value to an 'Int', returning +-- 'Nothing' if doing so would result in an overflow. +checkedIntegerToInt :: Integer -> Maybe Int +{-# INLINE checkedIntegerToInt #-} +-- We could use Data.Bits.toIntegralSized, but this hand-rolled +-- version is currently a bit faster as of GHC 9.2. +-- It's even faster to just match on the Integer constructors, but +-- we'd still need a fallback implementation for integer-simple. +checkedIntegerToInt x + | x == toInteger res = Just res + | otherwise = Nothing + where res = fromInteger x :: Int + + +------------------------------------------------------------------------ + +-- | This \"function\" has a superficial similarity to 'System.IO.Unsafe.unsafePerformIO' but +-- it is in fact a malevolent agent of chaos. It unpicks the seams of reality +-- (and the 'IO' monad) so that the normal rules no longer apply. It lulls you +-- into thinking it is reasonable, but when you are not looking it stabs you +-- in the back and aliases all of your mutable buffers. The carcass of many a +-- seasoned Haskell programmer lie strewn at its feet. +-- +-- Witness the trail of destruction: +-- +-- * +-- +-- * +-- +-- * +-- +-- * +-- +-- * +-- +-- * +-- +-- * +-- +-- Do not talk about \"safe\"! You do not know what is safe! +-- +-- Yield not to its blasphemous call! Flee traveller! Flee or you will be +-- corrupted and devoured! +-- +{-# INLINE accursedUnutterablePerformIO #-} +accursedUnutterablePerformIO :: IO a -> a +accursedUnutterablePerformIO (IO m) = case m realWorld# of (# _, r #) -> r + +-- --------------------------------------------------------------------- +-- +-- Standard C functions +-- + +memchr :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8) +memcmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO CInt +{-# DEPRECATED memset "Use Foreign.Marshal.Utils.fillBytes instead" #-} +-- | deprecated since @bytestring-0.11.5.0@ +memset :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8) + +#if !PURE_HASKELL + +foreign import ccall unsafe "string.h strlen" c_strlen + :: CString -> IO CSize + +foreign import ccall unsafe "string.h memchr" c_memchr + :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8) +memchr p w sz = c_memchr p (fromIntegral w) sz + +foreign import ccall unsafe "string.h memcmp" c_memcmp + :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt +memcmp p q s = c_memcmp p q (fromIntegral s) + +foreign import ccall unsafe "string.h memset" c_memset + :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8) +memset p w sz = c_memset p (fromIntegral w) sz + +#else + +c_strlen :: CString -> IO CSize +c_strlen p = checkedCast <$!> Pure.strlen (castPtr p) + +memchr p w len = Pure.memchr p w (checkedCast len) + +memcmp p q s = checkedCast <$!> Pure.memcmp p q s + +memset p w len = p <$ fillBytes p w (checkedCast len) + +#endif + +{-# DEPRECATED memcpy "Use Foreign.Marshal.Utils.copyBytes instead" #-} +-- | deprecated since @bytestring-0.11.5.0@ +memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () +memcpy = copyBytes + +memcpyFp :: ForeignPtr Word8 -> ForeignPtr Word8 -> Int -> IO () +memcpyFp fp fq s = unsafeWithForeignPtr fp $ \p -> + unsafeWithForeignPtr fq $ \q -> copyBytes p q s + +c_free_finalizer :: FunPtr (Ptr Word8 -> IO ()) +c_free_finalizer = finalizerFree + + + +-- --------------------------------------------------------------------- +-- +-- Uses our C code +-- + +#if !PURE_HASKELL + +foreign import ccall unsafe "static fpstring.h fps_reverse" c_reverse + :: Ptr Word8 -> Ptr Word8 -> CSize -> IO () + +foreign import ccall unsafe "static fpstring.h fps_intersperse" c_intersperse + :: Ptr Word8 -> Ptr Word8 -> CSize -> Word8 -> IO () + +foreign import ccall unsafe "static fpstring.h fps_maximum" c_maximum + :: Ptr Word8 -> CSize -> IO Word8 + +foreign import ccall unsafe "static fpstring.h fps_minimum" c_minimum + :: Ptr Word8 -> CSize -> IO Word8 + +foreign import ccall unsafe "static fpstring.h fps_count" c_count + :: Ptr Word8 -> CSize -> Word8 -> IO CSize + +-- fps_count works with both pointers and ByteArray# +foreign import ccall unsafe "static fpstring.h fps_count" c_count_ba + :: ByteArray# -> CSize -> Word8 -> IO CSize + +foreign import ccall unsafe "static fpstring.h fps_sort" c_sort + :: Ptr Word8 -> CSize -> IO () + +foreign import ccall unsafe "static sbs_elem_index" + c_elem_index :: ByteArray# -> Word8 -> CSize -> IO CPtrdiff + + + +foreign import ccall unsafe "static _hs_bytestring_uint_dec" c_uint_dec + :: CUInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_long_long_uint_dec" c_long_long_uint_dec + :: CULLong -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_int_dec" c_int_dec + :: CInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec" c_long_long_int_dec + :: CLLong -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_uint_hex" c_uint_hex + :: CUInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_long_long_uint_hex" c_long_long_uint_hex + :: CULLong -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_int_dec_padded9" + c_int_dec_padded9 :: CInt -> Ptr Word8 -> IO () + +foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec_padded18" + c_long_long_int_dec_padded18 :: CLLong -> Ptr Word8 -> IO () + +-- We import bytestring_is_valid_utf8 both unsafe and safe. For small inputs +-- we can use the unsafe version to get a bit more performance, but for large +-- inputs the safe version should be used to avoid GC synchronization pauses +-- in multithreaded contexts. + +foreign import ccall unsafe "bytestring_is_valid_utf8" cIsValidUtf8BA + :: ByteArray# -> CSize -> IO CInt + +foreign import ccall safe "bytestring_is_valid_utf8" cIsValidUtf8BASafe + :: ByteArray# -> CSize -> IO CInt + +foreign import ccall unsafe "bytestring_is_valid_utf8" cIsValidUtf8 + :: Ptr Word8 -> CSize -> IO CInt + +foreign import ccall safe "bytestring_is_valid_utf8" cIsValidUtf8Safe + :: Ptr Word8 -> CSize -> IO CInt + + +#else + +---------------------------------------------------------------- +-- Haskell version of functions in fpstring.c +---------------------------------------------------------------- + +-- | Reverse n-bytes from the second pointer into the first +c_reverse :: Ptr Word8 -> Ptr Word8 -> CSize -> IO () +c_reverse p1 p2 sz = Pure.reverseBytes p1 p2 (checkedCast sz) + +-- | find maximum char in a packed string +c_maximum :: Ptr Word8 -> CSize -> IO Word8 +c_maximum ptr sz = Pure.findMaximum ptr (checkedCast sz) + +-- | find minimum char in a packed string +c_minimum :: Ptr Word8 -> CSize -> IO Word8 +c_minimum ptr sz = Pure.findMinimum ptr (checkedCast sz) + +-- | count the number of occurrences of a char in a string +c_count :: Ptr Word8 -> CSize -> Word8 -> IO CSize +c_count ptr sz c = checkedCast <$!> Pure.countOcc ptr (checkedCast sz) c + +-- | count the number of occurrences of a char in a string +c_count_ba :: ByteArray# -> Int -> Word8 -> IO CSize +c_count_ba ba o c = checkedCast <$!> Pure.countOccBA ba o c + +-- | duplicate a string, interspersing the character through the elements of the +-- duplicated string +c_intersperse :: Ptr Word8 -> Ptr Word8 -> CSize -> Word8 -> IO () +c_intersperse p1 p2 sz e = Pure.intersperse p1 p2 (checkedCast sz) e + +-- | Quick sort bytes +c_sort :: Ptr Word8 -> CSize -> IO () +c_sort ptr sz = Pure.quickSort ptr (checkedCast sz) + +c_elem_index :: ByteArray# -> Word8 -> CSize -> IO CPtrdiff +c_elem_index ba e sz = checkedCast <$!> Pure.elemIndex ba e (checkedCast sz) + +cIsValidUtf8BA :: ByteArray# -> CSize -> IO CInt +cIsValidUtf8BA ba sz = bool_to_cint <$> Pure.isValidUtf8BA ba (checkedCast sz) + +cIsValidUtf8 :: Ptr Word8 -> CSize -> IO CInt +cIsValidUtf8 ptr sz = bool_to_cint <$> Pure.isValidUtf8 ptr (checkedCast sz) + +-- Pure module is compiled with `-fno-omit-yields` so it's always safe (it won't +-- block on large inputs) + +cIsValidUtf8BASafe :: ByteArray# -> CSize -> IO CInt +cIsValidUtf8BASafe = cIsValidUtf8BA + +cIsValidUtf8Safe :: Ptr Word8 -> CSize -> IO CInt +cIsValidUtf8Safe = cIsValidUtf8 + +bool_to_cint :: Bool -> CInt +bool_to_cint True = 1 +bool_to_cint False = 0 + +checkedCast :: (Bits a, Bits b, Integral a, Integral b) => a -> b +checkedCast x = + fromMaybe (errorWithoutStackTrace "checkedCast: overflow") + (toIntegralSized x) + +---------------------------------------------------------------- +-- Haskell version of functions in itoa.c +---------------------------------------------------------------- + +c_int_dec :: CInt -> Ptr Word8 -> IO (Ptr Word8) +c_int_dec = Pure.encodeSignedDec + +c_long_long_int_dec :: CLLong -> Ptr Word8 -> IO (Ptr Word8) +c_long_long_int_dec = Pure.encodeSignedDec + +c_uint_dec :: CUInt -> Ptr Word8 -> IO (Ptr Word8) +c_uint_dec = Pure.encodeUnsignedDec + +c_long_long_uint_dec :: CULLong -> Ptr Word8 -> IO (Ptr Word8) +c_long_long_uint_dec = Pure.encodeUnsignedDec + +c_uint_hex :: CUInt -> Ptr Word8 -> IO (Ptr Word8) +c_uint_hex = Pure.encodeUnsignedHex + +c_long_long_uint_hex :: CULLong -> Ptr Word8 -> IO (Ptr Word8) +c_long_long_uint_hex = Pure.encodeUnsignedHex + +c_int_dec_padded9 :: CInt -> Ptr Word8 -> IO () +c_int_dec_padded9 = Pure.encodeUnsignedDecPadded 9 + +c_long_long_int_dec_padded18 :: CLLong -> Ptr Word8 -> IO () +c_long_long_int_dec_padded18 = Pure.encodeUnsignedDecPadded 18 + +#endif diff --git a/Data/ByteString/Lazy.hs b/Data/ByteString/Lazy.hs --- a/Data/ByteString/Lazy.hs +++ b/Data/ByteString/Lazy.hs @@ -1,10 +1,7 @@ -{-# LANGUAGE CPP, BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -{-# OPTIONS_HADDOCK prune #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif +{-# OPTIONS_HADDOCK prune #-} + -- | -- Module : Data.ByteString.Lazy -- Copyright : (c) Don Stewart 2006 @@ -51,189 +48,201 @@ module Data.ByteString.Lazy ( - -- * The @ByteString@ type - ByteString, -- instances: Eq, Ord, Show, Read, Data, Typeable + -- * Lazy @ByteString@ + ByteString, + LazyByteString, -- * Introducing and eliminating 'ByteString's - empty, -- :: ByteString - singleton, -- :: Word8 -> ByteString - pack, -- :: [Word8] -> ByteString - unpack, -- :: ByteString -> [Word8] - fromStrict, -- :: Strict.ByteString -> ByteString - toStrict, -- :: ByteString -> Strict.ByteString - fromChunks, -- :: [Strict.ByteString] -> ByteString - toChunks, -- :: ByteString -> [Strict.ByteString] - foldrChunks, -- :: (S.ByteString -> a -> a) -> a -> ByteString -> a - foldlChunks, -- :: (a -> S.ByteString -> a) -> a -> ByteString -> a + empty, + singleton, + pack, + unpack, + fromStrict, + toStrict, + fromChunks, + toChunks, + foldrChunks, + foldlChunks, -- * 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) - unsnoc, -- :: ByteString -> Maybe (ByteString, Word8) - last, -- :: ByteString -> Word8 - tail, -- :: ByteString -> ByteString - init, -- :: ByteString -> ByteString - null, -- :: ByteString -> Bool - length, -- :: ByteString -> Int64 + cons, + cons', + snoc, + append, + head, + uncons, + unsnoc, + last, + tail, + init, + null, + length, -- * Transforming ByteStrings - map, -- :: (Word8 -> Word8) -> ByteString -> ByteString - reverse, -- :: ByteString -> ByteString - intersperse, -- :: Word8 -> ByteString -> ByteString - intercalate, -- :: ByteString -> [ByteString] -> ByteString - transpose, -- :: [ByteString] -> [ByteString] + map, + reverse, + intersperse, + intercalate, + transpose, -- * 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 + foldl, + foldl', + foldl1, + foldl1', + foldr, + foldr', + foldr1, + foldr1', -- ** 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 - compareLength, -- :: ByteString -> Int64 -> Ordering + concat, + concatMap, + any, + all, + maximum, + minimum, + compareLength, -- * 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 + scanl, + scanl1, + scanr, + scanr1, -- ** Accumulating maps - mapAccumL, -- :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) - mapAccumR, -- :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) + mapAccumL, + mapAccumR, -- ** Infinite ByteStrings - repeat, -- :: Word8 -> ByteString - replicate, -- :: Int64 -> Word8 -> ByteString - cycle, -- :: ByteString -> ByteString - iterate, -- :: (Word8 -> Word8) -> Word8 -> ByteString + repeat, + replicate, + cycle, + iterate, -- ** Unfolding ByteStrings - unfoldr, -- :: (a -> Maybe (Word8, a)) -> a -> ByteString + unfoldr, -- * 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] - stripPrefix, -- :: ByteString -> ByteString -> Maybe ByteString - stripSuffix, -- :: ByteString -> ByteString -> Maybe 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, -- :: Word8 -> ByteString -> [ByteString] - splitWith, -- :: (Word8 -> Bool) -> ByteString -> [ByteString] + split, + splitWith, -- * Predicates - isPrefixOf, -- :: ByteString -> ByteString -> Bool - isSuffixOf, -- :: ByteString -> ByteString -> Bool --- isInfixOf, -- :: ByteString -> ByteString -> Bool + isPrefixOf, + isSuffixOf, +-- isInfixOf, -- ** Search for arbitrary substrings --- isSubstringOf, -- :: ByteString -> ByteString -> Bool +-- isSubstringOf, -- * Searching ByteStrings -- ** Searching by equality - elem, -- :: Word8 -> ByteString -> Bool - notElem, -- :: Word8 -> ByteString -> Bool + elem, + notElem, -- ** Searching with a predicate - find, -- :: (Word8 -> Bool) -> ByteString -> Maybe Word8 - filter, -- :: (Word8 -> Bool) -> ByteString -> ByteString - partition, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) + find, + filter, + partition, -- * Indexing ByteStrings - index, -- :: ByteString -> Int64 -> Word8 - indexMaybe, -- :: ByteString -> Int64 -> Maybe Word8 - (!?), -- :: ByteString -> Int64 -> Maybe Word8 - elemIndex, -- :: Word8 -> ByteString -> Maybe Int64 - elemIndexEnd, -- :: Word8 -> ByteString -> Maybe Int64 - elemIndices, -- :: Word8 -> ByteString -> [Int64] - findIndex, -- :: (Word8 -> Bool) -> ByteString -> Maybe Int64 - findIndexEnd, -- :: (Word8 -> Bool) -> ByteString -> Maybe Int64 - findIndices, -- :: (Word8 -> Bool) -> ByteString -> [Int64] - count, -- :: Word8 -> ByteString -> Int64 + index, + indexMaybe, + (!?), + elemIndex, + elemIndexEnd, + elemIndices, + findIndex, + findIndexEnd, + findIndices, + count, -- * Zipping and unzipping ByteStrings - zip, -- :: ByteString -> ByteString -> [(Word8,Word8)] - zipWith, -- :: (Word8 -> Word8 -> c) -> ByteString -> ByteString -> [c] - packZipWith, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> ByteString - unzip, -- :: [(Word8,Word8)] -> (ByteString,ByteString) + zip, + zipWith, + packZipWith, + unzip, -- * Ordered ByteStrings --- sort, -- :: ByteString -> ByteString +-- sort, -- * Low level conversions -- ** Copying ByteStrings - copy, -- :: ByteString -> ByteString --- defrag, -- :: ByteString -> ByteString + copy, +-- defrag, -- * I\/O with 'ByteString's -- $IOChunk -- ** Standard input and output - getContents, -- :: IO ByteString - putStr, -- :: ByteString -> IO () - interact, -- :: (ByteString -> ByteString) -> IO () + getContents, + putStr, + 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 -> Int -> IO ByteString - hGetNonBlocking, -- :: Handle -> Int -> IO ByteString - hPut, -- :: Handle -> ByteString -> IO () - hPutNonBlocking, -- :: Handle -> ByteString -> IO ByteString - hPutStr, -- :: Handle -> ByteString -> IO () + hGetContents, + hGet, + hGetNonBlocking, + hPut, + hPutNonBlocking, + hPutStr, ) 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 + (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 L -- L for list/lazy +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 as S +import qualified Data.ByteString.Internal.Type as S import qualified Data.ByteString.Unsafe as S import Data.ByteString.Lazy.Internal -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative ((<$>)) -import Data.Monoid (Monoid(..)) -#endif +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) @@ -264,12 +273,12 @@ unpack :: ByteString -> [Word8] unpack = unpackBytes --- | /O(c)/ Convert a list of strict 'ByteString' into a lazy 'ByteString' -fromChunks :: [P.ByteString] -> ByteString -fromChunks = L.foldr chunk Empty +-- | /O(c)/ Convert a list of 'S.StrictByteString' into a 'LazyByteString' +fromChunks :: [S.StrictByteString] -> LazyByteString +fromChunks = List.foldr chunk Empty --- | /O(c)/ Convert a lazy 'ByteString' into a list of strict 'ByteString' -toChunks :: ByteString -> [P.ByteString] +-- | /O(c)/ Convert a 'LazyByteString' into a list of 'S.StrictByteString' +toChunks :: LazyByteString -> [S.StrictByteString] toChunks = foldrChunks (:) [] ------------------------------------------------------------------------ @@ -336,23 +345,31 @@ {-# INLINE snoc #-} -- | /O(1)/ Extract the first element of a ByteString, which must be non-empty. -head :: ByteString -> Word8 +-- +-- 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 +-- | /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) +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. -tail :: ByteString -> ByteString +-- +-- 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 @@ -361,22 +378,26 @@ -- | /O(n\/c)/ Extract the last element of a ByteString, which must be finite -- and non-empty. -last :: ByteString -> Word8 +-- +-- 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)/ Return all the elements of a 'ByteString' except the last one. -init :: ByteString -> ByteString +-- | /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 +-- | /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' @@ -420,15 +441,17 @@ (foldrChunks (Chunk . intersperse') Empty cs) where intersperse' :: P.ByteString -> P.ByteString intersperse' (S.BS fp l) = - S.unsafeCreate (2*l) $ \p' -> S.unsafeWithForeignPtr fp $ \p -> do - poke p' w - S.c_intersperse (p' `plusPtr` 1) p (fromIntegral l) w + 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 = L.map (\ss -> Chunk (S.pack ss) Empty) - (L.transpose (L.map unpack css)) +transpose css = List.map (\ss -> Chunk (S.pack ss) Empty) + (List.transpose (List.map unpack css)) --TODO: make this fast -- --------------------------------------------------------------------- @@ -457,25 +480,54 @@ 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 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldl1 :: HasCallStack => (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 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' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldl1' :: HasCallStack => (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' 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 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +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 @@ -503,24 +555,22 @@ any :: (Word8 -> Bool) -> ByteString -> Bool any f = foldrChunks (\c rest -> S.any f c || rest) False {-# 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 = foldrChunks (\c rest -> S.all f c && rest) True {-# INLINE all #-} --- todo fuse -- | /O(n)/ 'maximum' returns the maximum value from a 'ByteString' -maximum :: ByteString -> Word8 +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 :: ByteString -> Word8 +minimum :: HasCallStack => ByteString -> Word8 minimum Empty = errorEmptyList "minimum" minimum (Chunk c cs) = foldlChunks (\n c' -> n `min` S.minimum c') (S.minimum c) cs @@ -596,7 +646,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, ...] -- @@ -614,11 +664,49 @@ -- ^ input of length n -> ByteString -- ^ output of length n+1 -scanl f z = snd . foldl k (z,singleton z) - where - k (c,acc) a = let n = f c a in (n, acc `snoc` n) +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 @@ -655,7 +743,7 @@ -- | 'cycle' ties a finite ByteString into a circular one, or equivalently, -- the infinite repetition of the original ByteString. -- -cycle :: ByteString -> ByteString +cycle :: HasCallStack => ByteString -> ByteString cycle Empty = errorEmptyList "cycle" cycle cs = cs' where cs' = foldrChunks Chunk cs' cs @@ -689,8 +777,90 @@ 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 @[]@ if @n > 'length' xs@. +-- elements, or 'empty' if @n > 'length' xs@. drop :: Int64 -> ByteString -> ByteString drop i p | i <= 0 = p drop i cs0 = drop' i cs0 @@ -701,6 +871,22 @@ 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) @@ -715,7 +901,7 @@ in (Chunk c cs', cs'') --- | Similar to 'P.takeWhile', +-- | Similar to 'Prelude.takeWhile', -- returns the longest (possibly empty) prefix of elements -- satisfying the predicate. takeWhile :: (Word8 -> Bool) -> ByteString -> ByteString @@ -727,7 +913,28 @@ n | n < S.length c -> Chunk (S.take n c) Empty | otherwise -> Chunk c (takeWhile' cs) --- | Similar to 'P.dropWhile', +-- | 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 @@ -738,7 +945,30 @@ n | n < S.length c -> Chunk (S.drop n c) cs | otherwise -> dropWhile' cs --- | Similar to 'P.break', +-- | 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. -- @@ -755,14 +985,36 @@ | 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 occurence +-- | '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. -- @@ -779,7 +1031,7 @@ in (x : xs', xs'') -- | 'spanByte' breaks its ByteString argument at the first --- occurence of a byte other than its argument. It is more efficient +-- occurrence of a byte other than its argument. It is more efficient -- than 'span (==)' -- -- > span (==99) "abcd" == spanByte 99 "abcd" -- fromEnum 'c' == 99 @@ -795,7 +1047,7 @@ | otherwise -> (x' : [], x'' : xs) -} --- | Similar to 'P.span', +-- | Similar to 'Prelude.span', -- returns the longest (possibly empty) prefix of elements -- satisfying the predicate and the remainder of the string. -- @@ -804,6 +1056,25 @@ 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 @@ -820,6 +1091,7 @@ 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 @@ -847,11 +1119,12 @@ 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 sublist in the result contains only equal +-- argument. Moreover, each string in the result contains only equal -- elements. For example, -- -- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"] @@ -898,13 +1171,15 @@ -- '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 +intercalate s = concat . List.intersperse s -- --------------------------------------------------------------------- -- Indexing ByteStrings -- | /O(c)/ 'ByteString' index (subscript) operator, starting from 0. -index :: ByteString -> Int64 -> Word8 +-- +-- 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) @@ -968,7 +1243,7 @@ elemIndices :: Word8 -> ByteString -> [Int64] elemIndices w = elemIndices' 0 where elemIndices' _ Empty = [] - elemIndices' n (Chunk c cs) = L.map ((+n).fromIntegral) (S.elemIndices w c) + 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 @@ -1025,7 +1300,7 @@ findIndices :: (Word8 -> Bool) -> ByteString -> [Int64] findIndices k = findIndices' 0 where findIndices' _ Empty = [] - findIndices' n (Chunk c cs) = L.map ((+n).fromIntegral) (S.findIndices k c) + findIndices' n (Chunk c cs) = List.map ((+n).fromIntegral) (S.findIndices k c) ++ findIndices' (n + fromIntegral (S.length c)) cs {-# INLINE findIndices #-} @@ -1164,16 +1439,22 @@ 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 + -- 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 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 + 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. @@ -1192,26 +1473,46 @@ -- | /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)) +unzip ls = (pack (List.map fst ls), pack (List.map snd ls)) {-# INLINE unzip #-} -- --------------------------------------------------------------------- -- Special lists --- | /O(n)/ Return all initial segments of the given 'ByteString', shortest first. +-- | Returns all initial segments of the given 'ByteString', shortest first. inits :: ByteString -> [ByteString] -inits = (Empty :) . inits' - where inits' Empty = [] - inits' (Chunk c cs) = L.map (`Chunk` Empty) (L.tail (S.inits c)) - ++ L.map (Chunk c) (inits' cs) +-- see Note [Avoid NonEmpty combinators] in Data.ByteString +inits bs = NE.toList $! initsNE bs --- | /O(n)/ Return all final segments of the given 'ByteString', longest first. +-- | 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] -tails Empty = [Empty] -tails cs@(Chunk c cs') - | S.length c == 1 = cs : tails cs' - | otherwise = cs : tails (Chunk (S.unsafeTail c) cs') +-- 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 @@ -1349,10 +1650,12 @@ 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' between the --- writes, and hence 'hPut' alone might not be suitable for concurrent writes. +-- | 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 ()) @@ -1373,12 +1676,17 @@ 0 -> return bs _ -> return (Chunk c' cs) --- | A synonym for @hPut@, for compatibility +-- | A synonym for 'hPut', for compatibility -- hPutStr :: Handle -> ByteString -> IO () hPutStr = hPut --- | Write a ByteString to stdout +-- | 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 @@ -1395,23 +1703,26 @@ -- Common up near identical calls to `error' to reduce the number -- constant strings created when compiled: -errorEmptyList :: String -> a +errorEmptyList :: HasCallStack => String -> a errorEmptyList fun = moduleError fun "empty ByteString" {-# NOINLINE errorEmptyList #-} -moduleError :: String -> String -> a +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 = L.foldl' (flip Chunk) Empty +revNonEmptyChunks = List.foldl' (flip Chunk) Empty -- reverse a list of possibly-empty chunks into a lazy ByteString revChunks :: [P.ByteString] -> ByteString -revChunks = L.foldl' (flip chunk) Empty +revChunks = List.foldl' (flip chunk) Empty +intToInt64 :: Int -> Int64 +intToInt64 = fromIntegral @Int @Int64 + -- $IOChunk -- -- ⚠ Using lazy I\/O functions like 'readFile' or 'hGetContents' @@ -1438,7 +1749,7 @@ -- 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 lazy 'ByteString' variant +-- 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 diff --git a/Data/ByteString/Lazy/Char8.hs b/Data/ByteString/Lazy/Char8.hs --- a/Data/ByteString/Lazy/Char8.hs +++ b/Data/ByteString/Lazy/Char8.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE CPP, BangPatterns #-} -{-# OPTIONS_HADDOCK prune #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif +{-# OPTIONS_HADDOCK prune #-} + -- | -- Module : Data.ByteString.Lazy.Char8 -- Copyright : (c) Don Stewart 2006-2008 @@ -33,146 +31,176 @@ module Data.ByteString.Lazy.Char8 ( -- * The @ByteString@ type - ByteString, -- instances: Eq, Ord, Show, Read, Data, Typeable + ByteString, -- * Introducing and eliminating 'ByteString's - empty, -- :: ByteString - singleton, -- :: Char -> ByteString - pack, -- :: String -> ByteString - unpack, -- :: ByteString -> String - fromChunks, -- :: [Strict.ByteString] -> ByteString - toChunks, -- :: ByteString -> [Strict.ByteString] - fromStrict, -- :: Strict.ByteString -> ByteString - toStrict, -- :: ByteString -> Strict.ByteString + empty, + singleton, + pack, + unpack, + fromChunks, + toChunks, + fromStrict, + toStrict, -- * Basic interface - cons, -- :: Char -> ByteString -> ByteString - cons', -- :: Char -> ByteString -> ByteString - snoc, -- :: ByteString -> Char -> ByteString - append, -- :: ByteString -> ByteString -> ByteString - head, -- :: ByteString -> Char - uncons, -- :: ByteString -> Maybe (Char, ByteString) - last, -- :: ByteString -> Char - tail, -- :: ByteString -> ByteString - unsnoc, -- :: ByteString -> Maybe (ByteString, Char) - 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 - compareLength, -- :: ByteString -> Int -> Ordering + 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] - stripPrefix, -- :: ByteString -> ByteString -> Maybe ByteString - stripSuffix, -- :: ByteString -> ByteString -> Maybe 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 - indexMaybe, -- :: ByteString -> Int64 -> Maybe Char - (!?), -- :: ByteString -> Int64 -> Maybe Char - elemIndex, -- :: Char -> ByteString -> Maybe Int64 - elemIndexEnd, -- :: Char -> ByteString -> Maybe Int64 - elemIndices, -- :: Char -> ByteString -> [Int64] - findIndex, -- :: (Char -> Bool) -> ByteString -> Maybe Int64 - findIndexEnd, -- :: (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] - packZipWith, -- :: (Char -> Char -> Char) -> ByteString -> ByteString -> ByteString - 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 @@ -180,24 +208,24 @@ -- 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 @@ -205,8 +233,8 @@ import Data.ByteString.Lazy (fromChunks, toChunks ,empty,null,length,tail,init,append,reverse,transpose,cycle - ,concat,take,drop,splitAt,intercalate - ,isPrefixOf,isSuffixOf,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 @@ -218,21 +246,20 @@ 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.Internal (w2c, c2w, isSpaceWord8) +import Data.ByteString.Lazy.ReadInt +import Data.ByteString.Lazy.ReadNat -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative ((<$>)) -#endif +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 + (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) @@ -341,6 +368,12 @@ 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 'ByteString's. foldl1 :: (Char -> Char -> Char) -> ByteString -> Char @@ -357,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) @@ -388,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, ...] -- @@ -398,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 @@ -455,24 +533,70 @@ 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. -- @@ -483,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" @@ -732,66 +856,57 @@ unzip ls = (pack (fmap fst ls), pack (fmap snd ls)) {-# INLINE unzip #-} --- | 'lines' breaks a ByteString up into a list of ByteStrings at +-- | 'lines' lazily splits a ByteString into a list of ByteStrings at -- newline Chars (@'\\n'@). The resulting strings do not contain newlines. --- --- As of bytestring 0.9.0.3, this function is stricter than its --- list cousin. +-- 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) = loop0 c0 cs0 - 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 +lines (Chunk c0 cs0) = unNE $! go c0 cs0 + where + -- Natural NonEmpty -> List + unNE :: NonEmpty a -> [a] + unNE (a :| b) = a : b - -- 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'] + -- Strict in the first argument, lazy in the second. + consNE :: ByteString -> NonEmpty ByteString -> NonEmpty ByteString + consNE !a b = a :| (unNE $! b) - (Chunk c' cs') -> loop c' (c : line) cs' + -- 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 - Just n -> - let !c' = revChunks (B.unsafeTake n c : line) - in c' : loop0 (B.unsafeDrop (n+1) c) cs + -- 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 @@ -807,109 +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. +-- | Write a ByteString to a handle, appending a newline byte. -- --- Note: This function will overflow the Int for large integers. - -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) - 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 - 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) - 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 : combine2 b ns - combine2 _ ns = ns - - end n c cs = let !c' = chunk c cs - in (n, c') - - --- | 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 = List.foldl' (flip chunk) Empty diff --git a/Data/ByteString/Lazy/Internal.hs b/Data/ByteString/Lazy/Internal.hs --- a/Data/ByteString/Lazy/Internal.hs +++ b/Data/ByteString/Lazy/Internal.hs @@ -1,12 +1,10 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} -#if __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Unsafe #-} -#endif + {-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE TypeFamilies #-} + -- | -- Module : Data.ByteString.Lazy.Internal -- Copyright : (c) Don Stewart 2006-2008 @@ -25,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, @@ -49,65 +48,76 @@ import Prelude hiding (concat) -import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Internal.Type as S import Data.Word (Word8) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (plusPtr) import Foreign.Storable (Storable(sizeOf)) -#if MIN_VERSION_base(4,13,0) -import Data.Semigroup (Semigroup (sconcat, stimes)) -import Data.List.NonEmpty (NonEmpty ((:|))) -#elif MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup ((<>), sconcat, stimes)) +import Data.Semigroup (Semigroup (..)) import Data.List.NonEmpty (NonEmpty ((:|))) -#endif -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid (Monoid(..)) -#endif import Control.DeepSeq (NFData, rnf) import Data.String (IsString(..)) -import Data.Typeable (Typeable) -import Data.Data (Data(..), mkNoRepType) +import Data.Data (Data(..), mkConstr, mkNoRepType, Constr, DataType, Fixity(Prefix), constrIndex) -#if MIN_VERSION_base(4,7,0) 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 lazy 'ByteString' contains 8-bit bytes, or by using the operations +-- 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 (Typeable) --- See 'invariant' function later in this module for internal invariants. +#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 -#if MIN_VERSION_base(4,9,0) instance Semigroup ByteString where (<>) = append sconcat (b:|bs) = concat (b:bs) - stimes = times -#endif + stimes = times instance Monoid ByteString where mempty = Empty -#if MIN_VERSION_base(4,9,0) mappend = (<>) -#else - mappend = append -#endif mconcat = concat instance NFData ByteString where @@ -120,13 +130,11 @@ instance Read ByteString where readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ] -#if MIN_VERSION_base(4,7,0) -- | @since 0.10.12.0 instance IsList ByteString where type Item ByteString = Word8 fromList = packBytes toList = unpackBytes -#endif -- | Beware: 'fromString' truncates multi-byte characters to octets. -- e.g. "枯朶に烏のとまりけり秋の暮" becomes �6k�nh~�Q��n� @@ -135,15 +143,22 @@ instance Data ByteString where gfoldl f z txt = z packBytes `f` unpackBytes txt - toConstr _ = error "Data.ByteString.Lazy.ByteString.toConstr" - gunfold _ _ = error "Data.ByteString.Lazy.ByteString.gunfold" - dataTypeOf _ = mkNoRepType "Data.ByteString.Lazy.ByteString" + 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 [] = Empty packBytes cs0 = packChunks 32 cs0 where @@ -152,7 +167,6 @@ (bs, cs') -> Chunk bs (packChunks (min (n * 2) smallChunkSize) cs') packChars :: [Char] -> ByteString -packChars [] = Empty packChars cs0 = packChunks 32 cs0 where packChunks n cs = case S.packUptoLenChars n cs of @@ -169,15 +183,21 @@ ------------------------------------------------------------------------ +-- 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.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.BS _ len) cs) @@ -188,13 +208,13 @@ ------------------------------------------------------------------------ -- | Smart constructor for 'Chunk'. Guarantees the data type invariant. -chunk :: S.ByteString -> ByteString -> ByteString +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) @@ -202,7 +222,7 @@ -- | Consume the chunks of a lazy ByteString with a strict, tail-recursive, -- accumulating left fold. -foldlChunks :: (a -> S.ByteString -> a) -> a -> ByteString -> a +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 @@ -275,7 +295,6 @@ to [] = Empty to (cs:css) = go cs css -#if MIN_VERSION_base(4,9,0) -- | Repeats the given ByteString n times. times :: Integral a => a -> ByteString -> ByteString times 0 _ = Empty @@ -287,23 +306,22 @@ where go Empty = times (n-1) lbs0 go (Chunk c cs) = Chunk c (go cs) -#endif ------------------------------------------------------------------------ -- Conversions --- |/O(1)/ Convert a strict 'ByteString' into a lazy 'ByteString'. -fromStrict :: S.ByteString -> ByteString +-- |/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 lazy 'ByteString' into a strict 'ByteString'. +-- |/O(n)/ Convert a 'LazyByteString' into a 'S.StrictByteString'. -- --- Note that this is an /expensive/ operation that forces the whole lazy --- ByteString into memory and then copies all the data. If possible, try to +-- 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 :: ByteString -> S.ByteString +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 @@ -312,27 +330,23 @@ where -- It's still possible that the result is empty goLen0 _ Empty = S.BS S.nullForeignPtr 0 - goLen0 cs0 (Chunk (S.BS _ 0) cs) = goLen0 cs0 cs 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 bs (Chunk (S.BS _ 0) cs) = goLen1 cs0 bs cs goLen1 cs0 (S.BS _ bl) (Chunk (S.BS _ cl) cs) = - goLen cs0 (S.checkedAdd "Lazy.concat" bl 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.concat" total cl) cs + goLen cs0 (S.checkedAdd "Lazy.toStrict" total cl) cs goLen cs0 total Empty = - S.unsafeCreate total $ \ptr -> goCopy cs0 ptr + S.unsafeCreateFp total $ \ptr -> goCopy cs0 ptr -- Copy the data goCopy Empty !_ = return () - goCopy (Chunk (S.BS _ 0 ) cs) !ptr = goCopy cs ptr - goCopy (Chunk (S.BS fp len) cs) !ptr = - withForeignPtr fp $ \p -> do - S.memcpy ptr p len - goCopy cs (ptr `plusPtr` len) + goCopy (Chunk (S.BS fp len) cs) !ptr = do + S.memcpyFp ptr fp len + goCopy cs (ptr `S.plusForeignPtr` len) -- See the comment on Data.ByteString.Internal.concat for some background on -- this implementation. diff --git a/Data/ByteString/Lazy/ReadInt.hs b/Data/ByteString/Lazy/ReadInt.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/ReadInt.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE CPP #-} + +-- This file is also included by "Data.ByteString.ReadInt", after defining +-- "BYTESTRING_STRICT". The two modules share much of their code, but +-- the lazy version adds an outer loop over the chunks. + +#ifdef BYTESTRING_STRICT +module Data.ByteString.ReadInt +#else +module Data.ByteString.Lazy.ReadInt +#endif + ( readInt + , readInt8 + , readInt16 + , readInt32 + , readWord + , readWord8 + , readWord16 + , readWord32 + , readInt64 + , readWord64 + ) where + +import qualified Data.ByteString.Internal as BI +#ifdef BYTESTRING_STRICT +import Data.ByteString +#else +import Data.ByteString.Lazy +import Data.ByteString.Lazy.Internal +#endif +import Data.Bits (FiniteBits, isSigned) +import Data.ByteString.Internal (pattern BS, plusForeignPtr) +import Data.Int +import Data.Word +import Foreign.ForeignPtr (ForeignPtr) +import Foreign.Ptr (minusPtr, plusPtr) +import Foreign.Storable (Storable(..)) + +----- Public API + +-- | Try to read a signed 'Int' value from the 'ByteString', returning +-- @Just (val, str)@ on success, where @val@ is the value read and @str@ is the +-- rest of the input string. If the sequence of digits decodes to a value +-- larger than can be represented by an 'Int', the returned value will be +-- 'Nothing'. +-- +-- 'readInt' does not ignore leading whitespace, the value must start +-- immediately at the beginning of the input string. +-- +-- ==== __Examples__ +-- >>> readInt "-1729 sum of cubes" +-- Just (-1729," sum of cubes") +-- >>> readInt "+1: readInt also accepts a leading '+'" +-- Just (1, ": readInt also accepts a leading '+'") +-- >>> readInt "not a decimal number" +-- Nothing +-- >>> readInt "12345678901234567890 overflows maxBound" +-- Nothing +-- >>> readInt "-12345678901234567890 underflows minBound" +-- Nothing +-- +readInt :: ByteString -> Maybe (Int, ByteString) +readInt = _read + +-- | A variant of 'readInt' specialised to 'Int32'. +readInt32 :: ByteString -> Maybe (Int32, ByteString) +readInt32 = _read + +-- | A variant of 'readInt' specialised to 'Int16'. +readInt16 :: ByteString -> Maybe (Int16, ByteString) +readInt16 = _read + +-- | A variant of 'readInt' specialised to 'Int8'. +readInt8 :: ByteString -> Maybe (Int8, ByteString) +readInt8 = _read + +-- | Try to read a 'Word' value from the 'ByteString', returning +-- @Just (val, str)@ on success, where @val@ is the value read and @str@ is the +-- rest of the input string. If the sequence of digits decodes to a value +-- larger than can be represented by a 'Word', the returned value will be +-- 'Nothing'. +-- +-- 'readWord' does not ignore leading whitespace, the value must start with a +-- decimal digit immediately at the beginning of the input string. Leading @+@ +-- signs are not accepted. +-- +-- ==== __Examples__ +-- >>> readWord "1729 sum of cubes" +-- Just (1729," sum of cubes") +-- >>> readWord "+1729 has an explicit sign" +-- Nothing +-- >>> readWord "not a decimal number" +-- Nothing +-- >>> readWord "98765432109876543210 overflows maxBound" +-- Nothing +-- +readWord :: ByteString -> Maybe (Word, ByteString) +readWord = _read + +-- | A variant of 'readWord' specialised to 'Word32'. +readWord32 :: ByteString -> Maybe (Word32, ByteString) +readWord32 = _read + +-- | A variant of 'readWord' specialised to 'Word16'. +readWord16 :: ByteString -> Maybe (Word16, ByteString) +readWord16 = _read + +-- | A variant of 'readWord' specialised to 'Word8'. +readWord8 :: ByteString -> Maybe (Word8, ByteString) +readWord8 = _read + +-- | A variant of 'readInt' specialised to 'Int64'. +readInt64 :: ByteString -> Maybe (Int64, ByteString) +readInt64 = _read + +-- | A variant of 'readWord' specialised to 'Word64'. +readWord64 :: ByteString -> Maybe (Word64, ByteString) +readWord64 = _read + +-- | Polymorphic Int*/Word* reader +_read :: forall a. (Integral a, FiniteBits a, Bounded a) + => ByteString -> Maybe (a, ByteString) +{-# INLINE _read #-} +_read + | isSigned @a 0 + = \ bs -> signed bs >>= \ (r, s, d1) -> _readDecimal r s d1 + | otherwise + -- When the input is @16^n-1@, as is the case with 'maxBound' for + -- all the Word* types, the last decimal digit of 'maxBound' is 5. + = \ bs -> unsigned 5 bs >>= \ (r, s, d1) -> _readDecimal r s d1 + where + -- Returns: + -- * Mod 10 min/max bound remainder + -- * 2nd and later digits + -- * 1st digit + -- + -- When the input is @8*16^n-1@, as is the case with 'maxBound' for + -- all the Int* types, the last decimal digit of 'maxBound' is 7. + -- + signed :: ByteString -> Maybe (Word64, ByteString, Word64) + signed bs = do + (w, s) <- uncons bs + let d1 = fromDigit w + if | d1 <= 9 -> Just (7, s, d1) -- leading digit + | w == 0x2d -> unsigned 8 s -- minus sign + | w == 0x2b -> unsigned 7 s -- plus sign + | otherwise -> Nothing -- not a number + + unsigned :: Word64 -> ByteString -> Maybe (Word64, ByteString, Word64) + unsigned r bs = do + (w, s) <- uncons bs + let d1 = fromDigit w + if | d1 <= 9 -> Just (r, s, d1) -- leading digit + | otherwise -> Nothing -- not a number + +----- Fixed-width unsigned reader + +-- | Intermediate result from scanning a chunk, final output is +-- converted to the requested type once all chunks are processed. +-- +data Result = Overflow + | Result !Int -- number of bytes (digits) read + !Word64 -- accumulator value + +_readDecimal :: forall a. (Integral a, Bounded a) + => Word64 -- ^ abs(maxBound/minBound) `mod` 10 + -> ByteString -- ^ Input string + -> Word64 -- ^ First digit value + -> Maybe (a, ByteString) +{-# INLINE _readDecimal #-} +_readDecimal !r = consume + where + consume :: ByteString -> Word64 -> Maybe (a, ByteString) +#ifdef BYTESTRING_STRICT + consume (BS fp len) a = case _digits q r fp len a of + Result used acc + | used == len + -> convert acc empty + | otherwise + -> convert acc $ BS (fp `plusForeignPtr` used) (len - used) + _ -> Nothing +#else + -- All done + consume Empty acc = convert acc Empty + -- Process next chunk + consume (Chunk (BS fp len) cs) acc + = case _digits q r fp len acc of + Result used acc' + | used == len + -- process remaining chunks + -> consume cs acc' + | otherwise + -- ran into a non-digit + -> convert acc' $ + Chunk (BS (fp `plusForeignPtr` used) (len - used)) cs + _ -> Nothing +#endif + convert :: Word64 -> ByteString -> Maybe (a, ByteString) + convert !acc rest = + let !i = case r of + -- minBound @Int* `mod` 10 == 8 + 8 -> negate $ fromIntegral @Word64 @a acc + _ -> fromIntegral @Word64 @a acc + in Just (i, rest) + + -- The quotient of 'maxBound' divided by 10 is needed for + -- overflow checks, once the accumulator exceeds this value + -- no further digits can be added. If equal, the last digit + -- must not exceed the `r` value (max/min bound `mod` 10). + -- + q = fromIntegral @a @Word64 maxBound `div` 10 + +----- Per chunk decoder + +-- | Process as many digits as we can, returning the additional +-- number of digits found and the updated accumulator. If the +-- accumulator would overflow return 'Overflow'. +-- +_digits :: Word64 -- ^ maximum non-overflow value `div` 10 + -> Word64 -- ^ maximum non-overflow vavlue `mod` 10 + -> ForeignPtr Word8 -- ^ Input buffer + -> Int -- ^ Input length + -> Word64 -- ^ Accumulated value of leading digits + -> Result -- ^ Bytes read and final accumulator, + -- or else overflow indication +{-# INLINE _digits #-} +_digits !q !r fp len a = BI.accursedUnutterablePerformIO $ + BI.unsafeWithForeignPtr fp $ \ ptr -> do + let end = ptr `plusPtr` len + go ptr end ptr a + where + go !start !end = loop + where + loop !ptr !acc = getDigit >>= \ !d -> + if | d > 9 + -> return $ Result (ptr `minusPtr` start) acc + | acc < q || acc == q && d <= r + -> loop (ptr `plusPtr` 1) (acc * 10 + d) + | otherwise + -> return Overflow + where + getDigit :: IO Word64 + getDigit + | ptr /= end = fromDigit <$> peek ptr + | otherwise = pure 10 -- End of input + {-# NOINLINE getDigit #-} + -- 'getDigit' makes it possible to implement a single success + -- exit point from the loop. If instead we return 'Result' + -- from multiple places, when '_digits' is inlined we get (at + -- least GHC 8.10 through 9.2) for each exit path a separate + -- join point implementing the continuation code. GHC ticket + -- . + -- + -- The NOINLINE pragma is required to avoid inlining branches + -- that would restore multiple exit points. + +fromDigit :: Word8 -> Word64 +{-# INLINE fromDigit #-} +fromDigit = \ !w -> fromIntegral w - 0x30 -- i.e. w - '0' diff --git a/Data/ByteString/Lazy/ReadNat.hs b/Data/ByteString/Lazy/ReadNat.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/ReadNat.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE CPP #-} + +-- This file is included by "Data.ByteString.ReadInt", after defining +-- "BYTESTRING_STRICT". The two modules are largely identical, except for the +-- choice of ByteString type and the loops in `readNatural`, where the lazy +-- version needs to nest the inner loop inside a loop over the constituent +-- chunks. + +#ifdef BYTESTRING_STRICT +module Data.ByteString.ReadNat +#else +module Data.ByteString.Lazy.ReadNat +#endif + ( readInteger + , readNatural + ) where + +import qualified Data.ByteString.Internal as BI +#ifdef BYTESTRING_STRICT +import Data.ByteString +#else +import Data.ByteString.Lazy +import Data.ByteString.Lazy.Internal +#endif +import Data.Bits (finiteBitSize) +import Data.ByteString.Internal (pattern BS, plusForeignPtr) +import Data.Word +import Foreign.ForeignPtr (ForeignPtr) +import Foreign.Ptr (Ptr, minusPtr, plusPtr) +import Foreign.Storable (Storable(..)) +import Numeric.Natural (Natural) + +----- Public API + +-- | 'readInteger' reads an 'Integer' from the beginning of the 'ByteString'. +-- If there is no 'Integer' at the beginning of the string, it returns +-- 'Nothing', otherwise it just returns the 'Integer' read, and the rest of +-- the string. +-- +-- 'readInteger' does not ignore leading whitespace, the value must start +-- immediately at the beginning of the input string. +-- +-- ==== __Examples__ +-- >>> readInteger "-000111222333444555666777888999 all done" +-- Just (-111222333444555666777888999," all done") +-- >>> readInteger "+1: readInteger also accepts a leading '+'" +-- Just (1, ": readInteger also accepts a leading '+'") +-- >>> readInteger "not a decimal number" +-- Nothing +-- +readInteger :: ByteString -> Maybe (Integer, ByteString) +readInteger = \ bs -> do + (w, s) <- uncons bs + let d = fromDigit w + if | d <= 9 -> unsigned d s -- leading digit + | w == 0x2d -> negative s -- minus sign + | w == 0x2b -> positive s -- plus sign + | otherwise -> Nothing -- not a number + where + unsigned :: Word -> ByteString -> Maybe (Integer, ByteString) + unsigned d s = + let (!n, rest) = _readDecimal d s + !i = toInteger n + in Just (i, rest) + + positive :: ByteString -> Maybe (Integer, ByteString) + positive bs = do + (w, s) <- uncons bs + let d = fromDigit w + if | d <= 9 -> unsigned d s + | otherwise -> Nothing + + negative :: ByteString -> Maybe (Integer, ByteString) + negative bs = do + (w, s) <- uncons bs + let d = fromDigit w + if | d > 9 -> Nothing + | otherwise -> let (n, rest) = _readDecimal d s + !i = negate $ toInteger n + in Just (i, rest) + +-- | 'readNatural' reads a 'Natural' number from the beginning of the +-- 'ByteString'. If there is no 'Natural' number at the beginning of the +-- string, it returns 'Nothing', otherwise it just returns the number read, and +-- the rest of the string. +-- +-- 'readNatural' does not ignore leading whitespace, the value must start with +-- a decimal digit immediately at the beginning of the input string. Leading +-- @+@ signs are not accepted. +-- +-- ==== __Examples__ +-- >>> readNatural "000111222333444555666777888999 all done" +-- Just (111222333444555666777888999," all done") +-- >>> readNatural "+000111222333444555666777888999 explicit sign" +-- Nothing +-- >>> readNatural "not a decimal number" +-- Nothing +-- +readNatural :: ByteString -> Maybe (Natural, ByteString) +readNatural bs = do + (w, s) <- uncons bs + let d = fromDigit w + if | d <= 9 -> Just $! _readDecimal d s + | otherwise -> Nothing + +----- Internal implementation + +-- | Intermediate result from scanning a chunk, final output is +-- obtained via `convert` after all the chunks are processed. +-- +data Result = Result !Int -- Bytes consumed + !Word -- Value of LSW + !Int -- Digits in LSW + [Natural] -- Little endian MSW list + +_readDecimal :: Word -> ByteString -> (Natural, ByteString) +_readDecimal = + -- Having read one digit, we're about to read the 2nd So the digit count + -- up to 'safeLog' starts at 2. + consume [] 2 + where + consume :: [Natural] -> Int -> Word -> ByteString + -> (Natural, ByteString) +#ifdef BYTESTRING_STRICT + consume ns cnt acc (BS fp len) = + -- Having read one digit, we're about to read the 2nd + -- So the digit count up to 'safeLog' starts at 2. + case natdigits fp len acc cnt ns of + Result used acc' cnt' ns' + | used == len + -> convert acc' cnt' ns' $ empty + | otherwise + -> convert acc' cnt' ns' $ + BS (fp `plusForeignPtr` used) (len - used) +#else + -- All done + consume ns cnt acc Empty = convert acc cnt ns Empty + -- Process next chunk + consume ns cnt acc (Chunk (BS fp len) cs) + = case natdigits fp len acc cnt ns of + Result used acc' cnt' ns' + | used == len -- process more chunks + -> consume ns' cnt' acc' cs + | otherwise -- ran into a non-digit + -> let c = Chunk (BS (fp `plusForeignPtr` used) (len - used)) cs + in convert acc' cnt' ns' c +#endif + convert !acc !cnt !ns rest = + let !n = combine acc cnt ns + in (n, rest) + + -- | Merge least-significant word with reduction of of little-endian tail. + -- + -- The input is: + -- + -- * Least significant digits as a 'Word' (LSW) + -- * The number of digits that went into the LSW + -- * All the remaining digit groups ('safeLog' digits each), + -- in little-endian order + -- + -- The result is obtained by pairwise recursive combining of all the + -- full size digit groups, followed by multiplication by @10^cnt@ and + -- addition of the LSW. + combine :: Word -- ^ value of LSW + -> Int -- ^ count of digits in LSW + -> [Natural] -- ^ tail elements (base @10^'safeLog'@) + -> Natural + {-# INLINE combine #-} + combine !acc !_ [] = wordToNatural acc + combine !acc !cnt ns = + wordToNatural (10^cnt) * combine1 safeBase ns + wordToNatural acc + + -- | Recursive reduction of little-endian sequence of 'Natural'-valued + -- /digits/ in base @base@ (a power of 10). The base is squared after + -- each round. This shows better asymptotic performance than one word + -- at a time multiply-add folds. See: + -- + -- + combine1 :: Natural -> [Natural] -> Natural + combine1 _ [n] = n + combine1 base ns = combine1 (base * base) (combine2 base ns) + + -- | One round pairwise merge of numbers in base @base@. + combine2 :: Natural -> [Natural] -> [Natural] + combine2 base (n:m:ns) = let !t = m * base + n in t : combine2 base ns + combine2 _ ns = ns + +-- The intermediate representation is a little-endian sequence in base +-- @10^'safeLog'@, prefixed by an initial element in base @10^cnt@ for some +-- @cnt@ between 1 and 'safeLog'. The final result is obtained by recursive +-- pairwise merging of the tail followed by a final multiplication by @10^cnt@ +-- and addition of the head. +-- +natdigits :: ForeignPtr Word8 -- ^ Input chunk + -> Int -- ^ Chunk length + -> Word -- ^ accumulated element + -> Int -- ^ partial digit count + -> [Natural] -- ^ accumulated MSB elements + -> Result +{-# INLINE natdigits #-} +natdigits fp len = \ acc cnt ns -> + BI.accursedUnutterablePerformIO $ + BI.unsafeWithForeignPtr fp $ \ ptr -> do + let end = ptr `plusPtr` len + go ptr end acc cnt ns ptr + where + go !start !end = loop + where + loop :: Word -> Int -> [Natural] -> Ptr Word8 -> IO Result + loop !acc !cnt ns !ptr = getDigit >>= \ !d -> + if | d > 9 + -> return $ Result (ptr `minusPtr` start) acc cnt ns + | cnt < safeLog + -> loop (10*acc + d) (cnt+1) ns $ ptr `plusPtr` 1 + | otherwise + -> let !acc' = wordToNatural acc + in loop d 1 (acc' : ns) $ ptr `plusPtr` 1 + where + getDigit | ptr /= end = fromDigit <$> peek ptr + | otherwise = pure 10 -- End of input + {-# NOINLINE getDigit #-} + -- 'getDigit' makes it possible to implement a single success + -- exit point from the loop. If instead we return 'Result' + -- from multiple places, when 'natdigits' is inlined we get (at + -- least GHC 8.10 through 9.2) for each exit path a separate + -- join point implementing the continuation code. GHC ticket + -- . + -- + -- The NOINLINE pragma is required to avoid inlining branches + -- that would restore multiple exit points. + +----- Misc functions + +-- | Largest decimal digit count that never overflows the accumulator +-- The base 10 logarithm of 2 is ~0.30103, therefore 2^n has at least +-- @1 + floor (0.3 n)@ decimal digits. Therefore @floor (0.3 n)@, +-- digits cannot overflow the upper bound of an @n-bit@ word. +-- +safeLog :: Int +safeLog = 3 * finiteBitSize @Word 0 `div` 10 + +-- | 10-power base for little-endian sequence of ~Word-sized "digits" +safeBase :: Natural +safeBase = 10 ^ safeLog + +fromDigit :: Word8 -> Word +{-# INLINE fromDigit #-} +fromDigit = \ !w -> fromIntegral w - 0x30 -- i.e. w - '0' + +wordToNatural :: Word -> Natural +{-# INLINE wordToNatural #-} +wordToNatural = fromIntegral diff --git a/Data/ByteString/ReadInt.hs b/Data/ByteString/ReadInt.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/ReadInt.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE CPP #-} +#define BYTESTRING_STRICT +#include "Lazy/ReadInt.hs" diff --git a/Data/ByteString/ReadNat.hs b/Data/ByteString/ReadNat.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/ReadNat.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE CPP #-} +#define BYTESTRING_STRICT +#include "Lazy/ReadNat.hs" diff --git a/Data/ByteString/Short.hs b/Data/ByteString/Short.hs --- a/Data/ByteString/Short.hs +++ b/Data/ByteString/Short.hs @@ -1,14 +1,11 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif -- | -- Module : Data.ByteString.Short --- Copyright : (c) Duncan Coutts 2012-2013 +-- Copyright : (c) Duncan Coutts 2012-2013, Julian Ospald 2022 -- License : BSD-style -- --- Maintainer : duncan@community.haskell.org +-- Maintainer : hasufell@posteo.de -- Stability : stable -- Portability : ghc only -- @@ -36,20 +33,20 @@ -- | 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). -- - -- * 'B.ByteString' unshared: 9 words; 36 or 72 bytes. + -- * t'Data.ByteString.ByteString' unshared: 8 words; 32 or 64 bytes. -- - -- * 'B.ByteString' shared substring: 5 words; 20 or 40 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 'B.ByteString' use + -- 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 'B.ByteString' is unpacked into another constructor. + -- 'ShortByteString' or t'Data.ByteString.ByteString' is unpacked into another constructor. -- -- For example: -- @@ -61,7 +58,7 @@ -- string data. -- ** Heap fragmentation - -- | With GHC, the 'B.ByteString' representation uses /pinned/ memory, + -- | 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' @@ -70,23 +67,113 @@ -- small unpinned strings are allocated in the same way as normal heap -- allocations, rather than in a separate pinned area. - -- * Conversions - toShort, - fromShort, + -- * Introducing and eliminating 'ShortByteString's + empty, + singleton, pack, unpack, + fromShort, + toShort, - -- * Other operations - empty, null, length, index, indexMaybe, (!?), + -- * 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 ByteStrings as 'Foreign.C.String.CString's + -- ** Using ShortByteStrings as 'Foreign.C.String.CString's useAsCString, - useAsCStringLen + useAsCStringLen, ) where import Data.ByteString.Short.Internal diff --git a/Data/ByteString/Short/Internal.hs b/Data/ByteString/Short/Internal.hs --- a/Data/ByteString/Short/Internal.hs +++ b/Data/ByteString/Short/Internal.hs @@ -1,689 +1,1777 @@ -{-# LANGUAGE DeriveDataTypeable, CPP, BangPatterns, RankNTypes, - ForeignFunctionInterface, MagicHash, UnboxedTuples, - UnliftedFFITypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#if __GLASGOW_HASKELL__ >= 703 -{-# LANGUAGE Unsafe #-} -#endif -{-# OPTIONS_HADDOCK not-home #-} - --- | --- Module : Data.ByteString.Short.Internal --- Copyright : (c) Duncan Coutts 2012-2013 --- License : BSD-style --- --- Maintainer : duncan@community.haskell.org --- Stability : stable --- Portability : ghc only --- --- Internal representation of ShortByteString --- -module Data.ByteString.Short.Internal ( - - -- * The @ShortByteString@ type and representation - ShortByteString(..), - - -- * Conversions - toShort, - fromShort, - pack, - unpack, - - -- * Other operations - empty, null, length, index, indexMaybe, (!?), unsafeIndex, - - -- * Low level operations - createFromPtr, copyToPtr, - - -- * Low level conversions - -- ** Packing 'CString's and pointers - packCString, - packCStringLen, - - -- ** Using ByteStrings as 'CString's - useAsCString, - useAsCStringLen - ) where - -import Data.ByteString.Internal (ByteString(..), accursedUnutterablePerformIO, c_strlen) - -import Data.Typeable (Typeable) -import Data.Data (Data(..), mkNoRepType) -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup((<>))) -#endif -import Data.Monoid (Monoid(..)) -import Data.String (IsString(..)) -import Control.DeepSeq (NFData(..)) -import qualified Data.List as List (length) -import Foreign.C.String (CString, CStringLen) -#if MIN_VERSION_base(4,7,0) -import Foreign.C.Types (CSize(..), CInt(..)) -#elif MIN_VERSION_base(4,4,0) -import Foreign.C.Types (CSize(..), CInt(..), CLong(..)) -#else -import Foreign.C.Types (CSize, CInt, CLong) -#endif -import Foreign.Marshal.Alloc (allocaBytes) -import Foreign.ForeignPtr (touchForeignPtr) -#if MIN_VERSION_base(4,5,0) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -#else -import Foreign.ForeignPtr (unsafeForeignPtrToPtr) -#endif -import Foreign.Storable (pokeByteOff) - -#if MIN_VERSION_base(4,5,0) -import qualified GHC.Exts -#endif -import GHC.Exts ( Int(I#), Int#, Ptr(Ptr), Addr#, Char(C#) - , State#, RealWorld - , ByteArray#, MutableByteArray# - , newByteArray# -#if MIN_VERSION_base(4,6,0) - , newPinnedByteArray# - , byteArrayContents# - , unsafeCoerce# -#endif -#if MIN_VERSION_base(4,10,0) - , isByteArrayPinned# - , isTrue# -#endif - , sizeofByteArray# - , indexWord8Array#, indexCharArray# - , writeWord8Array#, writeCharArray# - , unsafeFreezeByteArray# ) -import GHC.IO -#if MIN_VERSION_base(4,6,0) -import GHC.ForeignPtr (ForeignPtr(ForeignPtr), ForeignPtrContents(PlainPtr)) -#else -import GHC.ForeignPtr (mallocPlainForeignPtrBytes) -#endif -import GHC.ST (ST(ST), runST) -import GHC.Word - -import Prelude ( Eq(..), Ord(..), Ordering(..), Read(..), Show(..) - , ($), ($!), error, (++), (.) - , String, userError - , Bool(..), (&&), otherwise - , (+), (-), fromIntegral - , return - , Maybe(..) ) - --- | 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. --- --- It is suitable for use as an internal representation for code that needs --- to keep many short strings in memory, but it /should not/ be used as an --- interchange type. That is, it should not generally be used in public APIs. --- The 'ByteString' type is usually more suitable for use in interfaces; it is --- more flexible and it supports a wide range of operations. --- -data ShortByteString = SBS ByteArray# - deriving Typeable - --- The ByteArray# representation is always word sized and aligned but with a --- known byte length. Our representation choice for ShortByteString is to leave --- the 0--3 trailing bytes undefined. This means we can use word-sized writes, --- but we have to be careful with reads, see equateBytes and compareBytes below. - - -instance Eq ShortByteString where - (==) = equateBytes - -instance Ord ShortByteString where - compare = compareBytes - -#if MIN_VERSION_base(4,9,0) -instance Semigroup ShortByteString where - (<>) = append -#endif - -instance Monoid ShortByteString where - mempty = empty -#if MIN_VERSION_base(4,9,0) - mappend = (<>) -#else - mappend = append -#endif - mconcat = concat - -instance NFData ShortByteString where - rnf SBS{} = () - -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 ] - -#if MIN_VERSION_base(4,7,0) --- | @since 0.10.12.0 -instance GHC.Exts.IsList ShortByteString where - type Item ShortByteString = Word8 - fromList = packBytes - toList = unpackBytes -#endif - --- | Beware: 'fromString' truncates multi-byte characters to octets. --- e.g. "枯朶に烏のとまりけり秋の暮" becomes �6k�nh~�Q��n� -instance IsString ShortByteString where - fromString = packChars - -instance Data ShortByteString where - gfoldl f z txt = z packBytes `f` unpackBytes txt - toConstr _ = error "Data.ByteString.Short.ShortByteString.toConstr" - gunfold _ _ = error "Data.ByteString.Short.ShortByteString.gunfold" - dataTypeOf _ = mkNoRepType "Data.ByteString.Short.ShortByteString" - ------------------------------------------------------------------------- --- 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. -index :: 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 (!?) #-} - -unsafeIndex :: ShortByteString -> Int -> Word8 -unsafeIndex sbs = indexWord8Array (asBA sbs) - -indexError :: ShortByteString -> Int -> a -indexError sbs i = - error $ "Data.ByteString.Short.index: error in array index; " ++ show i - ++ " not in range [0.." ++ show (length sbs) ++ ")" - - ------------------------------------------------------------------------- --- Internal utils - -asBA :: ShortByteString -> BA -asBA (SBS ba#) = BA# ba# - -create :: Int -> (forall s. MBA s -> ST s ()) -> ShortByteString -create len fill = - runST $ do - mba <- newByteArray len - fill mba - BA# ba# <- unsafeFreezeByteArray mba - return (SBS ba#) -{-# INLINE create #-} - ------------------------------------------------------------------------- --- 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) - let ptr = unsafeForeignPtrToPtr fptr - stToIO (copyAddrToByteArray ptr mba 0 len) - touchForeignPtr fptr - BA# ba# <- stToIO (unsafeFreezeByteArray mba) - return (SBS ba#) - - --- | /O(n)/. Convert a 'ShortByteString' into a 'ByteString'. --- -fromShort :: ShortByteString -> ByteString -#if MIN_VERSION_base(4,10,0) -fromShort (SBS b#) - | isTrue# (isByteArrayPinned# b#) = BS fp len - where - addr# = byteArrayContents# b# - fp = ForeignPtr addr# (PlainPtr (unsafeCoerce# b#)) - len = I# (sizeofByteArray# b#) -#endif -fromShort !sbs = unsafeDupablePerformIO (fromShortIO sbs) - -fromShortIO :: ShortByteString -> IO ByteString -fromShortIO sbs = do -#if MIN_VERSION_base(4,6,0) - let len = length sbs - mba@(MBA# mba#) <- stToIO (newPinnedByteArray len) - stToIO (copyByteArray (asBA sbs) 0 mba 0 len) - let fp = ForeignPtr (byteArrayContents# (unsafeCoerce# mba#)) - (PlainPtr mba#) - return (BS fp len) -#else - -- Before base 4.6 ForeignPtrContents is not exported from GHC.ForeignPtr - -- so we cannot get direct access to the mbarr# - let len = length sbs - fptr <- mallocPlainForeignPtrBytes len - let ptr = unsafeForeignPtrToPtr fptr - stToIO (copyByteArrayToAddr (asBA sbs) 0 ptr len) - touchForeignPtr fptr - return (BS fptr len) -#endif - - ------------------------------------------------------------------------- --- 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 = unpackBytes - -packChars :: [Char] -> ShortByteString -packChars cs = packLenChars (List.length cs) cs - -packBytes :: [Word8] -> ShortByteString -packBytes cs = packLenBytes (List.length cs) cs - -packLenChars :: Int -> [Char] -> ShortByteString -packLenChars len cs0 = - create len (\mba -> go mba 0 cs0) - where - go :: MBA s -> Int -> [Char] -> ST s () - go !_ !_ [] = return () - go !mba !i (c:cs) = do - writeCharArray mba i c - go mba (i+1) cs - -packLenBytes :: Int -> [Word8] -> ShortByteString -packLenBytes len ws0 = - create len (\mba -> go mba 0 ws0) - where - go :: MBA 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 effeciently is a tradeoff: on the one hand --- we would like to write a tight loop that just blats the list into memory, on --- the other hand we want it to be unpacked lazily so we don't end up with a --- massive list data structure in memory. --- --- Our strategy is to combine both: we will unpack lazily in reasonable sized --- chunks, where each chunk is unpacked strictly. --- --- unpackChars does the lazy loop, while unpackAppendBytes and --- unpackAppendChars do the chunks strictly. - -unpackChars :: ShortByteString -> [Char] -unpackChars bs = unpackAppendCharsLazy bs [] - -unpackBytes :: ShortByteString -> [Word8] -unpackBytes bs = unpackAppendBytesLazy bs [] - --- 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 - -equateBytes :: ShortByteString -> ShortByteString -> Bool -equateBytes sbs1 sbs2 = - let !len1 = length sbs1 - !len2 = length sbs2 - in len1 == len2 - && 0 == accursedUnutterablePerformIO - (memcmp_ByteArray (asBA sbs1) (asBA sbs2) len1) - -compareBytes :: ShortByteString -> ShortByteString -> Ordering -compareBytes sbs1 sbs2 = - let !len1 = length sbs1 - !len2 = length sbs2 - !len = min len1 len2 - in case accursedUnutterablePerformIO - (memcmp_ByteArray (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 (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 (sbs: sbss) = totalLen (acc + length sbs) sbss - - copy :: MBA 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 - - ------------------------------------------------------------------------- --- 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 - BA# ba# <- unsafeFreezeByteArray mba - return (SBS ba#) - - ------------------------------------------------------------------------- --- Primop wrappers - -data BA = BA# ByteArray# -data MBA s = MBA# (MutableByteArray# s) - -indexCharArray :: BA -> Int -> Char -indexCharArray (BA# ba#) (I# i#) = C# (indexCharArray# ba# i#) - -indexWord8Array :: BA -> Int -> Word8 -indexWord8Array (BA# ba#) (I# i#) = W8# (indexWord8Array# ba# i#) - -newByteArray :: Int -> ST s (MBA s) -newByteArray (I# len#) = - ST $ \s -> case newByteArray# len# s of - (# s, mba# #) -> (# s, MBA# mba# #) - -#if MIN_VERSION_base(4,6,0) -newPinnedByteArray :: Int -> ST s (MBA s) -newPinnedByteArray (I# len#) = - ST $ \s -> case newPinnedByteArray# len# s of - (# s, mba# #) -> (# s, MBA# mba# #) -#endif - -unsafeFreezeByteArray :: MBA s -> ST s BA -unsafeFreezeByteArray (MBA# mba#) = - ST $ \s -> case unsafeFreezeByteArray# mba# s of - (# s, ba# #) -> (# s, BA# ba# #) - -writeCharArray :: MBA s -> Int -> Char -> ST s () -writeCharArray (MBA# mba#) (I# i#) (C# c#) = - ST $ \s -> case writeCharArray# mba# i# c# s of - s -> (# s, () #) - -writeWord8Array :: MBA s -> Int -> Word8 -> ST s () -writeWord8Array (MBA# mba#) (I# i#) (W8# w#) = - ST $ \s -> case writeWord8Array# mba# i# w# s of - s -> (# s, () #) - -copyAddrToByteArray :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld () -copyAddrToByteArray (Ptr src#) (MBA# dst#) (I# dst_off#) (I# len#) = - ST $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of - s -> (# s, () #) - -copyByteArrayToAddr :: BA -> Int -> Ptr a -> Int -> ST RealWorld () -copyByteArrayToAddr (BA# src#) (I# src_off#) (Ptr dst#) (I# len#) = - ST $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of - s -> (# s, () #) - -copyByteArray :: BA -> Int -> MBA s -> Int -> Int -> ST s () -copyByteArray (BA# src#) (I# src_off#) (MBA# dst#) (I# dst_off#) (I# len#) = - ST $ \s -> case copyByteArray# src# src_off# dst# dst_off# len# s of - s -> (# s, () #) - - ------------------------------------------------------------------------- --- FFI imports - -memcmp_ByteArray :: BA -> BA -> Int -> IO CInt -memcmp_ByteArray (BA# ba1#) (BA# ba2#) len = - c_memcmp_ByteArray ba1# ba2# (fromIntegral len) - -foreign import ccall unsafe "string.h memcmp" - c_memcmp_ByteArray :: ByteArray# -> ByteArray# -> CSize -> IO CInt - - ------------------------------------------------------------------------- --- 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 - -#if MIN_VERSION_base(4,7,0) - --- These exist as real primops in ghc-7.8, and for before that we use --- FFI to C memcpy. -copyAddrToByteArray# = GHC.Exts.copyAddrToByteArray# -copyByteArrayToAddr# = GHC.Exts.copyByteArrayToAddr# - -#else - -copyAddrToByteArray# src dst dst_off len = - unIO_ (memcpy_AddrToByteArray dst (csize dst_off) src 0 (csize len)) - -copyAddrToByteArray0 :: Addr# -> MutableByteArray# s -> Int# - -> State# RealWorld -> State# RealWorld -copyAddrToByteArray0 src dst len = - unIO_ (memcpy_AddrToByteArray0 dst src (csize len)) - -{-# INLINE [0] copyAddrToByteArray# #-} -{-# RULES "copyAddrToByteArray# dst_off=0" - forall src dst len s. - copyAddrToByteArray# src dst 0# len s - = copyAddrToByteArray0 src dst len s #-} - -foreign import ccall unsafe "fpstring.h fps_memcpy_offsets" - memcpy_AddrToByteArray :: MutableByteArray# s -> CSize -> Addr# -> CSize -> CSize -> IO () - -foreign import ccall unsafe "string.h memcpy" - memcpy_AddrToByteArray0 :: MutableByteArray# s -> Addr# -> CSize -> IO () - - -copyByteArrayToAddr# src src_off dst len = - unIO_ (memcpy_ByteArrayToAddr dst 0 src (csize src_off) (csize len)) - -copyByteArrayToAddr0 :: ByteArray# -> Addr# -> Int# - -> State# RealWorld -> State# RealWorld -copyByteArrayToAddr0 src dst len = - unIO_ (memcpy_ByteArrayToAddr0 dst src (csize len)) - -{-# INLINE [0] copyByteArrayToAddr# #-} -{-# RULES "copyByteArrayToAddr# src_off=0" - forall src dst len s. - copyByteArrayToAddr# src 0# dst len s - = copyByteArrayToAddr0 src dst len s #-} - -foreign import ccall unsafe "fpstring.h fps_memcpy_offsets" - memcpy_ByteArrayToAddr :: Addr# -> CSize -> ByteArray# -> CSize -> CSize -> IO () - -foreign import ccall unsafe "string.h memcpy" - memcpy_ByteArrayToAddr0 :: Addr# -> ByteArray# -> CSize -> IO () - - -unIO_ :: IO () -> State# RealWorld -> State# RealWorld -unIO_ io s = case unIO io s of (# s, _ #) -> s - -csize :: Int# -> CSize -csize i# = fromIntegral (I# i#) -#endif - -#if MIN_VERSION_base(4,5,0) -copyByteArray# = GHC.Exts.copyByteArray# -#else -copyByteArray# src src_off dst dst_off len s = - unST_ (unsafeIOToST - (memcpy_ByteArray dst (csize dst_off) src (csize src_off) (csize len))) s - where - unST (ST st) = st - unST_ st s = case unST st s of (# s, _ #) -> s - -foreign import ccall unsafe "fpstring.h fps_memcpy_offsets" - memcpy_ByteArray :: MutableByteArray# s -> CSize -> ByteArray# -> CSize -> CSize -> IO () -#endif - --- | /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 <- 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 bs action = - allocaBytes (l+1) $ \buf -> do - copyToPtr bs 0 buf (fromIntegral l) - pokeByteOff buf l (0::Word8) - action buf - where l = length bs - --- | /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. --- --- @since 0.10.10.0 -useAsCStringLen :: ShortByteString -> (CStringLen -> IO a) -> IO a -useAsCStringLen bs action = - allocaBytes l $ \buf -> do - copyToPtr bs 0 buf (fromIntegral l) - action (buf, l) - where l = length bs - --- --------------------------------------------------------------------- --- Internal utilities - -moduleErrorIO :: 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 +{-# LANGUAGE CPP #-} +{-# LANGUAGE Unsafe #-} + +{-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnliftedFFITypes #-} + +#include "bytestring-cpp-macros.h" + +-- | +-- Module : Data.ByteString.Short.Internal +-- Copyright : (c) Duncan Coutts 2012-2013, Julian Ospald 2022 +-- License : BSD-style +-- +-- Maintainer : hasufell@posteo.de +-- Stability : stable +-- Portability : ghc only +-- +-- Internal representation of ShortByteString +-- +module Data.ByteString.Short.Internal ( + + -- * The @ShortByteString@ type and representation + ShortByteString(.., SBS), + + -- * Introducing and eliminating 'ShortByteString's + empty, + singleton, + pack, + unpack, + fromShort, + toShort, + + -- * Basic interface + snoc, + cons, + append, + last, + tail, + uncons, + head, + init, + unsnoc, + null, + length, + + -- * Transforming ShortByteStrings + map, + reverse, + intercalate, + + -- * Reducing 'ShortByteString's (folds) + foldl, + foldl', + foldl1, + foldl1', + + foldr, + foldr', + foldr1, + foldr1', + + -- ** Special folds + all, + any, + concat, + + -- ** Generating and unfolding ShortByteStrings + replicate, + unfoldr, + unfoldrN, + + -- * Substrings + + -- ** Breaking strings + take, + takeEnd, + takeWhileEnd, + takeWhile, + drop, + dropEnd, + dropWhile, + dropWhileEnd, + breakEnd, + break, + span, + spanEnd, + splitAt, + split, + splitWith, + stripSuffix, + stripPrefix, + + -- * Predicates + isInfixOf, + isPrefixOf, + isSuffixOf, + + -- ** Search for arbitrary substrings + breakSubstring, + + -- * Searching ShortByteStrings + + -- ** Searching by equality + elem, + + -- ** Searching with a predicate + find, + filter, + partition, + + -- * Indexing ShortByteStrings + index, + indexMaybe, + (!?), + elemIndex, + elemIndices, + count, + findIndex, + findIndices, + unsafeIndex, + + -- * Low level operations + createFromPtr, + copyToPtr, + + -- ** Encoding validation + isValidUtf8, + + -- * Low level conversions + -- ** Packing 'Foreign.C.String.CString's and pointers + packCString, + packCStringLen, + + -- ** Using ShortByteStrings as 'Foreign.C.String.CString's + useAsCString, + useAsCStringLen, + ) where + +import Data.ByteString.Internal.Type + ( ByteString(..) + , unsafeDupablePerformIO + , accursedUnutterablePerformIO + , checkedAdd + , c_elem_index + , cIsValidUtf8BASafe + , cIsValidUtf8BA + ) + +import Data.Array.Byte + ( ByteArray(..), MutableByteArray(..) ) +import Data.Bits + ( FiniteBits (finiteBitSize) + , shiftL +#if HS_UNALIGNED_ByteArray_OPS_OK + , shiftR +#endif + , (.&.) + , (.|.) + ) +import Data.Data + ( Data(..) ) +import Data.Monoid + ( Monoid(..) ) +import Data.Semigroup + ( Semigroup(..), stimesMonoid ) +import Data.List.NonEmpty + ( NonEmpty(..) ) +import Data.String + ( IsString(..) ) +import Control.Applicative + ( pure ) +import Control.DeepSeq + ( NFData ) +import Control.Exception + ( assert ) +import Control.Monad + ( (>>) ) +import Foreign.C.String + ( CString + , CStringLen + ) +import Foreign.Marshal.Alloc + ( allocaBytes ) +import Foreign.Storable + ( pokeByteOff ) +import GHC.Exts + ( Int(I#), Int#, Ptr(Ptr), Addr#, Char(C#) + , State#, RealWorld + , ByteArray#, MutableByteArray# + , newByteArray# + , byteArrayContents# + , unsafeCoerce# + , copyMutableByteArray# + , isByteArrayPinned# + , isTrue# + , compareByteArrays# + , sizeofByteArray# + , indexWord8Array#, indexCharArray# + , writeWord8Array# + , unsafeFreezeByteArray# +#if HS_UNALIGNED_ByteArray_OPS_OK + ,writeWord64Array# + ,indexWord8ArrayAsWord64# +#endif + , setByteArray# + , sizeofByteArray# + , indexWord8Array#, indexCharArray# + , writeWord8Array# + , unsafeFreezeByteArray# + , touch# ) +import GHC.Generics + ( Generic ) +import GHC.IO hiding ( unsafeDupablePerformIO ) +import GHC.ForeignPtr + ( ForeignPtr(ForeignPtr) + , ForeignPtrContents(PlainPtr) + ) +import GHC.ST + ( ST(ST) + , runST + ) +import GHC.Stack.Types + ( HasCallStack ) +import GHC.Word +import Prelude + ( Eq(..), Ord(..), Ordering(..), Read(..), Show(..) + , ($), ($!), error, (++), (.), (||) + , String, userError + , Bool(..), (&&), otherwise + , (+), (-), fromIntegral + , (*) + , (^) + , (<$>) + , return + , Maybe(..) + , not + , snd + ) + +import qualified Data.ByteString.Internal.Type as BS + +import qualified Data.List as List +import qualified GHC.Exts +import qualified Language.Haskell.TH.Syntax as TH + +-- | A compact representation of a 'Word8' vector. +-- +-- It has a lower memory overhead than a 'ByteString' and does not +-- contribute to heap fragmentation. It can be converted to or from a +-- 'ByteString' (at the cost of copying the string data). It supports very few +-- other operations. +-- +newtype ShortByteString = + -- | @since 0.12.0.0 + ShortByteString + { unShortByteString :: ByteArray + -- ^ @since 0.12.0.0 + } + deriving (Eq, TH.Lift, Data, Generic, NFData) + +-- | Prior to @bytestring-0.12@ 'SBS' was a genuine constructor of 'ShortByteString', +-- but now it is a bundled pattern synonym, provided as a compatibility shim. +pattern SBS :: ByteArray# -> ShortByteString +pattern SBS x = ShortByteString (ByteArray x) +{-# COMPLETE SBS #-} + +-- | Lexicographic order. +instance Ord ShortByteString where + compare = compareBytes + +-- Instead of deriving Semigroup / Monoid , we stick to our own implementations +-- of mappend / mconcat, because they are safer with regards to overflows +-- (see prop_32bitOverflow_Short_mconcat test). +-- ByteArray is likely to catch up starting from GHC 9.6: +-- * https://gitlab.haskell.org/ghc/ghc/-/merge_requests/8272 +-- * https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9128 + +instance Semigroup ShortByteString where + (<>) = append + sconcat (b:|bs) = concat (b:bs) + stimes = stimesMonoid + +instance Monoid ShortByteString where + mempty = empty + mappend = (<>) + mconcat = concat + +instance Show ShortByteString where + showsPrec p ps r = showsPrec p (unpackChars ps) r + +instance Read ShortByteString where + readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ] + +-- | @since 0.10.12.0 +instance GHC.Exts.IsList ShortByteString where + type Item ShortByteString = Word8 + fromList = ShortByteString . GHC.Exts.fromList + fromListN = (ShortByteString .) . GHC.Exts.fromListN + toList = GHC.Exts.toList . unShortByteString + +-- | Beware: 'fromString' truncates multi-byte characters to octets. +-- e.g. "枯朶に烏のとまりけり秋の暮" becomes �6k�nh~�Q��n� +instance IsString ShortByteString where + fromString = packChars + +------------------------------------------------------------------------ +-- Simple operations + +-- | /O(1)/. The empty 'ShortByteString'. +empty :: ShortByteString +empty = create 0 (\_ -> return ()) + +-- | /O(1)/ The length of a 'ShortByteString'. +length :: ShortByteString -> Int +length (SBS barr#) = I# (sizeofByteArray# barr#) + +-- | /O(1)/ Test whether a 'ShortByteString' is empty. +null :: ShortByteString -> Bool +null sbs = length sbs == 0 + +-- | /O(1)/ 'ShortByteString' index (subscript) operator, starting from 0. +-- +-- This is a partial function, consider using 'indexMaybe' instead. +index :: HasCallStack => ShortByteString -> Int -> Word8 +index sbs i + | i >= 0 && i < length sbs = unsafeIndex sbs i + | otherwise = indexError sbs i + +-- | /O(1)/ 'ShortByteString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 0.11.0.0 +indexMaybe :: ShortByteString -> Int -> Maybe Word8 +indexMaybe sbs i + | i >= 0 && i < length sbs = Just $! unsafeIndex sbs i + | otherwise = Nothing +{-# INLINE indexMaybe #-} + +-- | /O(1)/ 'ShortByteString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 0.11.0.0 +(!?) :: ShortByteString -> Int -> Maybe Word8 +(!?) = indexMaybe +{-# INLINE (!?) #-} + +-- | /O(1)/ Unsafe indexing without bounds checking. +unsafeIndex :: ShortByteString -> Int -> Word8 +unsafeIndex sbs = indexWord8Array (asBA sbs) + +indexError :: HasCallStack => ShortByteString -> Int -> a +indexError sbs i = + moduleError "index" $ "error in array index: " ++ show i + ++ " not in range [0.." ++ show (length sbs) ++ "]" + +------------------------------------------------------------------------ +-- Internal utils + +asBA :: ShortByteString -> ByteArray +asBA (ShortByteString ba) = ba + +create :: Int -> (forall s. MutableByteArray s -> ST s ()) -> ShortByteString +create len fill = + assert (len >= 0) $ runST $ do + mba <- newByteArray len + fill mba + ShortByteString <$> unsafeFreezeByteArray mba +{-# INLINE create #-} + +-- | Given the maximum size needed and a function to make the contents +-- of a ShortByteString, createAndTrim makes the 'ShortByteString'. +-- The generating function is required to return the actual final size +-- (<= the maximum size) and the result value. The resulting byte array +-- is realloced to this size. +createAndTrim :: Int -> (forall s. MutableByteArray s -> ST s (Int, a)) -> (ShortByteString, a) +createAndTrim maxLen fill = + assert (maxLen >= 0) $ runST $ do + mba <- newByteArray maxLen + (len, res) <- fill mba + if assert (0 <= len && len <= maxLen) $ len >= maxLen + then do + ba <- unsafeFreezeByteArray mba + return (ShortByteString ba, res) + else do + mba2 <- newByteArray len + copyMutableByteArray mba 0 mba2 0 len + ba <- unsafeFreezeByteArray mba2 + return (ShortByteString ba, res) +{-# INLINE createAndTrim #-} + +createAndTrim' :: Int -> (forall s. MutableByteArray s -> ST s Int) -> ShortByteString +createAndTrim' maxLen fill = + assert (maxLen >= 0) $ runST $ do + mba <- newByteArray maxLen + len <- fill mba + if assert (0 <= len && len <= maxLen) $ len >= maxLen + then do + ShortByteString <$> unsafeFreezeByteArray mba + else do + mba2 <- newByteArray len + copyMutableByteArray mba 0 mba2 0 len + ShortByteString <$> unsafeFreezeByteArray mba2 +{-# INLINE createAndTrim' #-} + +-- | Like createAndTrim, but with two buffers at once +createAndTrim2 :: Int -> Int -> (forall s. MutableByteArray s -> MutableByteArray s -> ST s (Int, Int)) -> (ShortByteString, ShortByteString) +createAndTrim2 maxLen1 maxLen2 fill = + runST $ do + mba1 <- newByteArray maxLen1 + mba2 <- newByteArray maxLen2 + (len1, len2) <- fill mba1 mba2 + sbs1 <- freeze' len1 maxLen1 mba1 + sbs2 <- freeze' len2 maxLen2 mba2 + pure (sbs1, sbs2) + where + freeze' :: Int -> Int -> MutableByteArray s -> ST s ShortByteString + freeze' len maxLen mba = + if assert (0 <= len && len <= maxLen) $ len >= maxLen + then do + ShortByteString <$> unsafeFreezeByteArray mba + else do + mba2 <- newByteArray len + copyMutableByteArray mba 0 mba2 0 len + ShortByteString <$> unsafeFreezeByteArray mba2 +{-# INLINE createAndTrim2 #-} + +isPinned :: ByteArray# -> Bool +isPinned ba# = isTrue# (isByteArrayPinned# ba#) + +------------------------------------------------------------------------ +-- Conversion to and from ByteString + +-- | /O(n)/. Convert a 'ByteString' into a 'ShortByteString'. +-- +-- This makes a copy, so does not retain the input string. +-- +toShort :: ByteString -> ShortByteString +toShort !bs = unsafeDupablePerformIO (toShortIO bs) + +toShortIO :: ByteString -> IO ShortByteString +toShortIO (BS fptr len) = do + mba <- stToIO (newByteArray len) + BS.unsafeWithForeignPtr fptr $ \ptr -> + stToIO (copyAddrToByteArray ptr mba 0 len) + ShortByteString <$> stToIO (unsafeFreezeByteArray mba) + +-- | /O(n)/. Convert a 'ShortByteString' into a 'ByteString'. +-- +fromShort :: ShortByteString -> ByteString +fromShort sbs@(SBS b#) + | isPinned b# = BS inPlaceFp len + | otherwise = BS.unsafeCreateFp len $ \fp -> + BS.unsafeWithForeignPtr fp $ \p -> copyToPtr sbs 0 p len + where + inPlaceFp = ForeignPtr (byteArrayContents# b#) + (PlainPtr (unsafeCoerce# b#)) + len = I# (sizeofByteArray# b#) + +-- | /O(1)/ Convert a 'Word8' into a 'ShortByteString' +-- +-- @since 0.11.3.0 +singleton :: Word8 -> ShortByteString +singleton = \w -> create 1 (\mba -> writeWord8Array mba 0 w) + +------------------------------------------------------------------------ +-- Packing and unpacking from lists + +-- | /O(n)/. Convert a list into a 'ShortByteString' +pack :: [Word8] -> ShortByteString +pack = packBytes + +-- | /O(n)/. Convert a 'ShortByteString' into a list. +unpack :: ShortByteString -> [Word8] +unpack sbs = GHC.Exts.build (unpackFoldr sbs) +{-# INLINE unpack #-} + +-- +-- Have unpack fuse with good list consumers +-- +unpackFoldr :: ShortByteString -> (Word8 -> a -> a) -> a -> a +unpackFoldr sbs k z = foldr k z sbs +{-# INLINE [0] unpackFoldr #-} + +{-# RULES +"ShortByteString unpack-list" [1] forall bs . + unpackFoldr bs (:) [] = unpackBytes bs + #-} + +packChars :: [Char] -> ShortByteString +packChars = \cs -> packLenBytes (List.length cs) (List.map BS.c2w cs) + +packBytes :: [Word8] -> ShortByteString +packBytes = \ws -> packLenBytes (List.length ws) ws + +packLenBytes :: Int -> [Word8] -> ShortByteString +packLenBytes len ws0 = + create len (\mba -> go mba 0 ws0) + where + go :: MutableByteArray s -> Int -> [Word8] -> ST s () + go !_ !_ [] = return () + go !mba !i (w:ws) = do + writeWord8Array mba i w + go mba (i+1) ws + +-- Unpacking bytestrings into lists efficiently is a tradeoff: on the one hand +-- we would like to write a tight loop that just blats the list into memory, on +-- the other hand we want it to be unpacked lazily so we don't end up with a +-- massive list data structure in memory. +-- +-- Our strategy is to combine both: we will unpack lazily in reasonable sized +-- chunks, where each chunk is unpacked strictly. +-- +-- unpackChars does the lazy loop, while unpackAppendBytes and +-- unpackAppendChars do the chunks strictly. + +unpackChars :: ShortByteString -> [Char] +unpackChars sbs = unpackAppendCharsLazy sbs [] + +unpackBytes :: ShortByteString -> [Word8] +unpackBytes sbs = unpackAppendBytesLazy sbs [] + + +-- Why 100 bytes you ask? Because on a 64bit machine the list we allocate +-- takes just shy of 4k which seems like a reasonable amount. +-- (5 words per list element, 8 bytes per word, 100 elements = 4000 bytes) + +unpackAppendCharsLazy :: ShortByteString -> [Char] -> [Char] +unpackAppendCharsLazy sbs = go 0 (length sbs) + where + sz = 100 + + go off len cs + | len <= sz = unpackAppendCharsStrict sbs off len cs + | otherwise = unpackAppendCharsStrict sbs off sz remainder + where remainder = go (off+sz) (len-sz) cs + +unpackAppendBytesLazy :: ShortByteString -> [Word8] -> [Word8] +unpackAppendBytesLazy sbs = go 0 (length sbs) + where + sz = 100 + + go off len ws + | len <= sz = unpackAppendBytesStrict sbs off len ws + | otherwise = unpackAppendBytesStrict sbs off sz remainder + where remainder = go (off+sz) (len-sz) ws + +-- For these unpack functions, since we're unpacking the whole list strictly we +-- build up the result list in an accumulator. This means we have to build up +-- the list starting at the end. So our traversal starts at the end of the +-- buffer and loops down until we hit the sentinal: + +unpackAppendCharsStrict :: ShortByteString -> Int -> Int -> [Char] -> [Char] +unpackAppendCharsStrict !sbs off len = go (off-1) (off-1 + len) + where + go !sentinal !i acc + | i == sentinal = acc + | otherwise = let !c = indexCharArray (asBA sbs) i + in go sentinal (i-1) (c:acc) + +unpackAppendBytesStrict :: ShortByteString -> Int -> Int -> [Word8] -> [Word8] +unpackAppendBytesStrict !sbs off len = go (off-1) (off-1 + len) + where + go !sentinal !i acc + | i == sentinal = acc + | otherwise = let !w = indexWord8Array (asBA sbs) i + in go sentinal (i-1) (w:acc) + + +------------------------------------------------------------------------ +-- Eq and Ord implementations + +compareBytes :: ShortByteString -> ShortByteString -> Ordering +compareBytes sbs1 sbs2 = + let !len1 = length sbs1 + !len2 = length sbs2 + !len = min len1 len2 + in case compareByteArrays (asBA sbs1) (asBA sbs2) len of + i | i < 0 -> LT + | i > 0 -> GT + | len2 > len1 -> LT + | len2 < len1 -> GT + | otherwise -> EQ + +------------------------------------------------------------------------ +-- Appending and concatenation + +append :: ShortByteString -> ShortByteString -> ShortByteString +append src1 src2 = + let !len1 = length src1 + !len2 = length src2 + in create (checkedAdd "Short.append" len1 len2) $ \dst -> do + copyByteArray (asBA src1) 0 dst 0 len1 + copyByteArray (asBA src2) 0 dst len1 len2 + +concat :: [ShortByteString] -> ShortByteString +concat = \sbss -> + create (totalLen 0 sbss) (\dst -> copy dst 0 sbss) + where + totalLen !acc [] = acc + totalLen !acc (curr : rest) + = totalLen (checkedAdd "Short.concat" acc $ length curr) rest + + copy :: MutableByteArray s -> Int -> [ShortByteString] -> ST s () + copy !_ !_ [] = return () + copy !dst !off (src : sbss) = do + let !len = length src + copyByteArray (asBA src) 0 dst off len + copy dst (off + len) sbss + +-- --------------------------------------------------------------------- +-- Basic interface + +infixr 5 `cons` --same as list (:) +infixl 5 `snoc` + +-- | /O(n)/ Append a byte to the end of a 'ShortByteString' +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +snoc :: ShortByteString -> Word8 -> ShortByteString +snoc = \sbs c -> let len = length sbs + newLen = checkedAdd "Short.snoc" len 1 + in create newLen $ \mba -> do + copyByteArray (asBA sbs) 0 mba 0 len + writeWord8Array mba len c + +-- | /O(n)/ 'cons' is analogous to (:) for lists. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +cons :: Word8 -> ShortByteString -> ShortByteString +cons c = \sbs -> let len = length sbs + newLen = checkedAdd "Short.cons" len 1 + in create newLen $ \mba -> do + writeWord8Array mba 0 c + copyByteArray (asBA sbs) 0 mba 1 len + +-- | /O(1)/ Extract the last element of a ShortByteString, which must be finite and non-empty. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- This is a partial function, consider using 'unsnoc' instead. +-- +-- @since 0.11.3.0 +last :: HasCallStack => ShortByteString -> Word8 +last = \sbs -> case null sbs of + True -> errorEmptySBS "last" + False -> indexWord8Array (asBA sbs) (length sbs - 1) + +-- | /O(n)/ Extract the elements after the head of a ShortByteString, which must be non-empty. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- This is a partial function, consider using 'uncons' instead. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +tail :: HasCallStack => ShortByteString -> ShortByteString +tail = \sbs -> + let l = length sbs + nl = l - 1 + in case null sbs of + True -> errorEmptySBS "tail" + False -> create nl $ \mba -> copyByteArray (asBA sbs) 1 mba 0 nl + +-- | /O(n)/ Extract the 'head' and 'tail' of a ShortByteString, returning 'Nothing' +-- if it is empty. +-- +-- @since 0.11.3.0 +uncons :: ShortByteString -> Maybe (Word8, ShortByteString) +uncons = \sbs -> + let l = length sbs + nl = l - 1 + in if | l <= 0 -> Nothing + | otherwise -> let h = indexWord8Array (asBA sbs) 0 + t = create nl $ \mba -> copyByteArray (asBA sbs) 1 mba 0 nl + in Just (h, t) + +-- | /O(1)/ Extract the first element of a ShortByteString, which must be non-empty. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- This is a partial function, consider using 'uncons' instead. +-- +-- @since 0.11.3.0 +head :: HasCallStack => ShortByteString -> Word8 +head = \sbs -> case null sbs of + True -> errorEmptySBS "head" + False -> indexWord8Array (asBA sbs) 0 + +-- | /O(n)/ Return all the elements of a 'ShortByteString' except the last one. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- This is a partial function, consider using 'unsnoc' instead. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +init :: HasCallStack => ShortByteString -> ShortByteString +init = \sbs -> + let l = length sbs + nl = l - 1 + in case null sbs of + True -> errorEmptySBS "init" + False -> create nl $ \mba -> copyByteArray (asBA sbs) 0 mba 0 nl + +-- | /O(n)/ Extract the 'init' and 'last' of a ShortByteString, returning 'Nothing' +-- if it is empty. +-- +-- @since 0.11.3.0 +unsnoc :: ShortByteString -> Maybe (ShortByteString, Word8) +unsnoc = \sbs -> + let l = length sbs + nl = l - 1 + in if | l <= 0 -> Nothing + | otherwise -> let l' = indexWord8Array (asBA sbs) (l - 1) + i = create nl $ \mba -> copyByteArray (asBA sbs) 0 mba 0 nl + in Just (i, l') + + +-- --------------------------------------------------------------------- +-- Transformations + +-- | /O(n)/ 'map' @f xs@ is the ShortByteString obtained by applying @f@ to each +-- element of @xs@. +-- +-- @since 0.11.3.0 +map :: (Word8 -> Word8) -> ShortByteString -> ShortByteString +map f = \sbs -> + let l = length sbs + ba = asBA sbs + in create l (\mba -> go ba mba 0 l) + where + go :: ByteArray -> MutableByteArray s -> Int -> Int -> ST s () + go !ba !mba !i !l + | i >= l = return () + | otherwise = do + let w = indexWord8Array ba i + writeWord8Array mba i (f w) + go ba mba (i+1) l + + +-- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order. +-- +-- @since 0.11.3.0 +reverse :: ShortByteString -> ShortByteString +reverse = \sbs -> + let l = length sbs + ba = asBA sbs +#if HS_UNALIGNED_ByteArray_OPS_OK + in create l (\mba -> go ba mba l) + where + go :: forall s. ByteArray -> MutableByteArray s -> Int -> ST s () + go !ba !mba !l = do + -- this is equivalent to: (q, r) = l `quotRem` 8 + let q = l `shiftR` 3 + r = l .&. 7 + i' <- goWord8Chunk 0 r + goWord64Chunk i' 0 q + where + + goWord64Chunk :: Int -> Int -> Int -> ST s () + goWord64Chunk !off !i' !cl = loop i' + where + loop :: Int -> ST s () + loop !i + | i >= cl = return () + | otherwise = do + let w = indexWord8ArrayAsWord64 ba (off + (i * 8)) + writeWord64Array mba (cl - 1 - i) (byteSwap64 w) + loop (i+1) + + goWord8Chunk :: Int -> Int -> ST s Int + goWord8Chunk !i' !cl = loop i' + where + loop :: Int -> ST s Int + loop !i + | i >= cl = return i + | otherwise = do + let w = indexWord8Array ba i + writeWord8Array mba (l - 1 - i) w + loop (i+1) +#else + in create l (\mba -> go ba mba 0 l) + where + go :: ByteArray -> MutableByteArray s -> Int -> Int -> ST s () + go !ba !mba !i !l + | i >= l = return () + | otherwise = do + let w = indexWord8Array ba i + writeWord8Array mba (l - 1 - i) w + go ba mba (i+1) l +#endif + + +-- | /O(n)/ The 'intercalate' function takes a 'ShortByteString' and a list of +-- 'ShortByteString's and concatenates the list after interspersing the first +-- argument between each element of the list. +-- +-- @since 0.11.3.0 +intercalate :: ShortByteString -> [ShortByteString] -> ShortByteString +intercalate sep = \case + [] -> empty + [x] -> x -- This branch exists for laziness, not speed + (sbs:t) -> let !totalLen = List.foldl' (\acc chunk -> acc +! length sep +! length chunk) (length sbs) t + in create totalLen (\mba -> + let !l = length sbs + in copyByteArray (asBA sbs) 0 mba 0 l >> go mba l t) + where + ba = asBA sep + lba = length sep + + go :: MutableByteArray s -> Int -> [ShortByteString] -> ST s () + go _ _ [] = pure () + go mba !off (chunk:chunks) = do + let lc = length chunk + copyByteArray ba 0 mba off lba + copyByteArray (asBA chunk) 0 mba (off + lba) lc + go mba (off + lc + lba) chunks + (+!) = checkedAdd "Short.intercalate" + + +-- --------------------------------------------------------------------- +-- Reducing 'ShortByteString's + +-- | 'foldl', applied to a binary operator, a starting value (typically +-- the left-identity of the operator), and a ShortByteString, reduces the +-- ShortByteString using the binary operator, from left to right. +-- +-- @since 0.11.3.0 +foldl :: (a -> Word8 -> a) -> a -> ShortByteString -> a +foldl f v = List.foldl f v . unpack + +-- | 'foldl'' is like 'foldl', but strict in the accumulator. +-- +-- @since 0.11.3.0 +foldl' :: (a -> Word8 -> a) -> a -> ShortByteString -> a +foldl' f v = List.foldl' f v . unpack + +-- | 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a ShortByteString, +-- reduces the ShortByteString using the binary operator, from right to left. +-- +-- @since 0.11.3.0 +foldr :: (Word8 -> a -> a) -> a -> ShortByteString -> a +foldr k v = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = v + | otherwise = k (w n) (go (n + 1)) + in go 0 +{-# INLINE foldr #-} + +-- | 'foldr'' is like 'foldr', but strict in the accumulator. +-- +-- @since 0.11.3.0 +foldr' :: (Word8 -> a -> a) -> a -> ShortByteString -> a +foldr' k v = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !ix !v' | ix < 0 = v' + | otherwise = go (ix - 1) (k (w ix) v') + in go (l - 1) v +{-# INLINE foldr' #-} + +-- | 'foldl1' is a variant of 'foldl' that has no starting value +-- argument, and thus must be applied to non-empty 'ShortByteString's. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- @since 0.11.3.0 +foldl1 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ShortByteString -> Word8 +foldl1 k = List.foldl1 k . unpack + +-- | 'foldl1'' is like 'foldl1', but strict in the accumulator. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- @since 0.11.3.0 +foldl1' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ShortByteString -> Word8 +foldl1' k = List.foldl1' k . unpack + +-- | 'foldr1' is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty 'ShortByteString's +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- @since 0.11.3.0 +foldr1 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ShortByteString -> Word8 +foldr1 k = List.foldr1 k . unpack + +-- | 'foldr1'' is a variant of 'foldr1', but is strict in the +-- accumulator. +-- +-- @since 0.11.3.0 +foldr1' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ShortByteString -> Word8 +foldr1' k = \sbs -> if null sbs then errorEmptySBS "foldr1'" else foldr' k (last sbs) (init sbs) + + + +-- --------------------------------------------------------------------- +-- Special folds + +-- | /O(n)/ Applied to a predicate and a 'ShortByteString', 'all' determines +-- if all elements of the 'ShortByteString' satisfy the predicate. +-- +-- @since 0.11.3.0 +all :: (Word8 -> Bool) -> ShortByteString -> Bool +all k = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = True + | otherwise = k (w n) && go (n + 1) + in go 0 + + +-- | /O(n)/ Applied to a predicate and a 'ShortByteString', 'any' determines if +-- any element of the 'ShortByteString' satisfies the predicate. +-- +-- @since 0.11.3.0 +any :: (Word8 -> Bool) -> ShortByteString -> Bool +any k = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = False + | otherwise = k (w n) || go (n + 1) + in go 0 + + + +-- --------------------------------------------------------------------- +-- Substrings + +-- | /O(n)/ 'take' @n@, applied to a ShortByteString @xs@, returns the prefix +-- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +take :: Int -> ShortByteString -> ShortByteString +take = \n -> \sbs -> let sl = length sbs + in if | n >= sl -> sbs + | n <= 0 -> empty + | otherwise -> + create n $ \mba -> copyByteArray (asBA sbs) 0 mba 0 n + +-- | Similar to 'Prelude.takeWhile', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate. +-- +-- @since 0.11.3.0 +takeWhile :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +takeWhile f = \sbs -> take (findIndexOrLength (not . f) sbs) sbs + +-- | /O(n)/ @'takeEnd' n xs@ is equivalent to @'drop' ('length' xs - n) xs@. +-- Takes @n@ elements from end of bytestring. +-- +-- >>> takeEnd 3 "abcdefg" +-- "efg" +-- >>> takeEnd 0 "abcdefg" +-- "" +-- >>> takeEnd 4 "abc" +-- "abc" +-- +-- @since 0.11.3.0 +takeEnd :: Int -> ShortByteString -> ShortByteString +takeEnd n = \sbs -> let sl = length sbs + in if | n >= sl -> sbs + | n <= 0 -> empty + | otherwise -> create n $ \mba -> copyByteArray (asBA sbs) (max 0 (sl - n)) mba 0 n + + +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate. +-- +-- @'takeWhileEnd' p@ is equivalent to @'reverse' . 'takeWhile' p . 'reverse'@. +-- +-- @since 0.11.3.0 +takeWhileEnd :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +takeWhileEnd f = \sbs -> drop (findFromEndUntil (not . f) sbs) sbs + +-- | /O(n)/ 'drop' @n@ @xs@ returns the suffix of @xs@ after the first n elements, or 'empty' if @n > 'length' xs@. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +drop :: Int -> ShortByteString -> ShortByteString +drop = \n -> \sbs -> + let len = length sbs + in if | n <= 0 -> sbs + | n >= len -> empty + | otherwise -> + let newLen = len - n + in create newLen $ \mba -> copyByteArray (asBA sbs) n mba 0 newLen + +-- | /O(n)/ @'dropEnd' n xs@ is equivalent to @'take' ('length' xs - n) xs@. +-- Drops @n@ elements from end of bytestring. +-- +-- >>> dropEnd 3 "abcdefg" +-- "abcd" +-- >>> dropEnd 0 "abcdefg" +-- "abcdefg" +-- >>> dropEnd 4 "abc" +-- "" +-- +-- @since 0.11.3.0 +dropEnd :: Int -> ShortByteString -> ShortByteString +dropEnd n = \sbs -> let sl = length sbs + nl = sl - n + in if | n >= sl -> empty + | n <= 0 -> sbs + | otherwise -> create nl $ \mba -> copyByteArray (asBA sbs) 0 mba 0 nl + +-- | Similar to 'Prelude.dropWhile', +-- drops the longest (possibly empty) prefix of elements +-- satisfying the predicate and returns the remainder. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +dropWhile :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +dropWhile f = \sbs -> drop (findIndexOrLength (not . f) sbs) sbs + +-- | Similar to 'Prelude.dropWhileEnd', +-- drops the longest (possibly empty) suffix of elements +-- satisfying the predicate and returns the remainder. +-- +-- @'dropWhileEnd' p@ is equivalent to @'reverse' . 'dropWhile' p . 'reverse'@. +-- +-- @since 0.11.3.0 +dropWhileEnd :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +dropWhileEnd f = \sbs -> take (findFromEndUntil (not . f) sbs) sbs + +-- | Returns the longest (possibly empty) suffix of elements which __do not__ +-- satisfy the predicate and the remainder of the string. +-- +-- 'breakEnd' @p@ is equivalent to @'spanEnd' (not . p)@ and to @('takeWhileEnd' (not . p) &&& 'dropWhileEnd' (not . p))@. +-- +-- @since 0.11.3.0 +breakEnd :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +breakEnd p = \sbs -> splitAt (findFromEndUntil p sbs) sbs + +-- | Similar to 'Prelude.break', +-- returns the longest (possibly empty) prefix of elements which __do not__ +-- satisfy the predicate and the remainder of the string. +-- +-- 'break' @p@ is equivalent to @'span' (not . p)@ and to @('takeWhile' (not . p) &&& 'dropWhile' (not . p))@. +-- +-- @since 0.11.3.0 +break :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +break p = \sbs -> case findIndexOrLength p sbs of n -> (take n sbs, drop n sbs) +{-# INLINE break #-} + +-- | Similar to 'Prelude.span', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate and the remainder of the string. +-- +-- 'span' @p@ is equivalent to @'break' (not . p)@ and to @('takeWhile' p &&& 'dropWhile' p)@. +-- +-- @since 0.11.3.0 +span :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +span p = break (not . p) + +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate and the remainder of the string. +-- +-- 'spanEnd' @p@ is equivalent to @'breakEnd' (not . p)@ and to @('takeWhileEnd' p &&& 'dropWhileEnd' p)@. +-- +-- We have +-- +-- > spanEnd (not . isSpace) "x y z" == ("x y ", "z") +-- +-- and +-- +-- > spanEnd (not . isSpace) sbs +-- > == +-- > let (x, y) = span (not . isSpace) (reverse sbs) in (reverse y, reverse x) +-- +-- @since 0.11.3.0 +spanEnd :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +spanEnd p = \sbs -> splitAt (findFromEndUntil (not . p) sbs) sbs + +-- | /O(n)/ 'splitAt' @n sbs@ is equivalent to @('take' n sbs, 'drop' n sbs)@. +-- +-- Note: copies the substrings +-- +-- @since 0.11.3.0 +splitAt :: Int -> ShortByteString -> (ShortByteString, ShortByteString) +splitAt n = \sbs -> if + | n <= 0 -> (empty, sbs) + | otherwise -> + let slen = length sbs + in if | n >= slen -> (sbs, empty) + | otherwise -> + let rlen = slen - n + lsbs = create n $ \mba -> copyByteArray (asBA sbs) 0 mba 0 n + rsbs = create rlen $ \mba -> copyByteArray (asBA sbs) n mba 0 rlen + in (lsbs, rsbs) + +-- | /O(n)/ Break a 'ShortByteString' into pieces separated by the byte +-- argument, consuming the delimiter. I.e. +-- +-- > split 10 "a\nb\nd\ne" == ["a","b","d","e"] -- fromEnum '\n' == 10 +-- > split 97 "aXaXaXa" == ["","X","X","X",""] -- fromEnum 'a' == 97 +-- > split 120 "x" == ["",""] -- fromEnum 'x' == 120 +-- > split undefined "" == [] -- and not [""] +-- +-- and +-- +-- > intercalate [c] . split c == id +-- > split == splitWith . (==) +-- +-- Note: copies the substrings +-- +-- @since 0.11.3.0 +split :: Word8 -> ShortByteString -> [ShortByteString] +split w = splitWith (== w) + + +-- | /O(n)/ Splits a 'ShortByteString' into components delimited by +-- separators, where the predicate returns True for a separator element. +-- The resulting components do not contain the separators. Two adjacent +-- separators result in an empty component in the output. eg. +-- +-- > splitWith (==97) "aabbaca" == ["","","bb","c",""] -- fromEnum 'a' == 97 +-- > splitWith undefined "" == [] -- and not [""] +-- +-- @since 0.11.3.0 +splitWith :: (Word8 -> Bool) -> ShortByteString -> [ShortByteString] +splitWith p = \sbs -> if + | null sbs -> [] + | otherwise -> go sbs + where + go sbs' + | null sbs' = [empty] + | otherwise = + case break p sbs' of + (a, b) + | null b -> [a] + | otherwise -> a : go (tail b) + + +-- | /O(n)/ The 'stripSuffix' function takes two ShortByteStrings and returns 'Just' +-- the remainder of the second iff the first is its suffix, and otherwise +-- 'Nothing'. +-- +-- @since 0.11.3.0 +stripSuffix :: ShortByteString -> ShortByteString -> Maybe ShortByteString +stripSuffix sbs1 = \sbs2 -> do + let l1 = length sbs1 + l2 = length sbs2 + if | isSuffixOf sbs1 sbs2 -> + if null sbs1 + then Just sbs2 + else Just $! create (l2 - l1) $ \dst -> do + copyByteArray (asBA sbs2) 0 dst 0 (l2 - l1) + | otherwise -> Nothing + +-- | /O(n)/ The 'stripPrefix' function takes two ShortByteStrings and returns 'Just' +-- the remainder of the second iff the first is its prefix, and otherwise +-- 'Nothing'. +-- +-- @since 0.11.3.0 +stripPrefix :: ShortByteString -> ShortByteString -> Maybe ShortByteString +stripPrefix sbs1 = \sbs2 -> do + let l1 = length sbs1 + l2 = length sbs2 + if | isPrefixOf sbs1 sbs2 -> + if null sbs1 + then Just sbs2 + else Just $! create (l2 - l1) $ \dst -> do + copyByteArray (asBA sbs2) l1 dst 0 (l2 - l1) + | otherwise -> Nothing + + +-- --------------------------------------------------------------------- +-- Unfolds and replicates + + +-- | /O(n)/ 'replicate' @n x@ is a ShortByteString of length @n@ with @x@ +-- the value of every element. The following holds: +-- +-- > replicate w c = unfoldr w (\u -> Just (u,u)) c +-- +-- @since 0.11.3.0 +replicate :: Int -> Word8 -> ShortByteString +replicate w c + | w <= 0 = empty + | otherwise = create w (\mba -> setByteArray mba 0 w (fromIntegral c)) + + +-- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' +-- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a +-- ShortByteString from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the ShortByteString or returns +-- 'Just' @(a,b)@, in which case, @a@ is the next byte in the string, +-- and @b@ is the seed value for further production. +-- +-- This function is not efficient/safe. It will build a list of @[Word8]@ +-- and run the generator until it returns `Nothing`, otherwise recurse infinitely, +-- then finally create a 'ShortByteString'. +-- +-- If you know the maximum length, consider using 'unfoldrN'. +-- +-- Examples: +-- +-- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0 +-- > == pack [0, 1, 2, 3, 4, 5] +-- +-- @since 0.11.3.0 +unfoldr :: (a -> Maybe (Word8, a)) -> a -> ShortByteString +unfoldr f = \x0 -> packBytesRev $ go x0 [] + where + go x words' = case f x of + Nothing -> words' + Just (w, x') -> go x' (w:words') + +-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a ShortByteString from a seed +-- value. However, the length of the result is limited by the first +-- argument to 'unfoldrN'. This function is more efficient than 'unfoldr' +-- when the maximum length of the result is known. +-- +-- The following equation relates 'unfoldrN' and 'unfoldr': +-- +-- > fst (unfoldrN n f s) == take n (unfoldr f s) +-- +-- @since 0.11.3.0 +unfoldrN :: forall a. Int -> (a -> Maybe (Word8, a)) -> a -> (ShortByteString, Maybe a) +unfoldrN i f = \x0 -> + if | i < 0 -> (empty, Just x0) + | otherwise -> createAndTrim i $ \mba -> go mba x0 0 + + where + go :: forall s. MutableByteArray s -> a -> Int -> ST s (Int, Maybe a) + go !mba !x !n = go' x n + where + go' :: a -> Int -> ST s (Int, Maybe a) + go' !x' !n' + | n' == i = return (n', Just x') + | otherwise = case f x' of + Nothing -> return (n', Nothing) + Just (w, x'') -> do + writeWord8Array mba n' w + go' x'' (n'+1) +{-# INLINE unfoldrN #-} + + + +-- -------------------------------------------------------------------- +-- Predicates + +-- | Check whether one string is a substring of another. +-- +-- @since 0.11.3.0 +isInfixOf :: ShortByteString -> ShortByteString -> Bool +isInfixOf sbs = \s -> null sbs || not (null $ snd $ (GHC.Exts.inline breakSubstring) sbs s) + +-- |/O(n)/ The 'isPrefixOf' function takes two ShortByteStrings and returns 'True' +-- iff the first is a prefix of the second. +-- +-- @since 0.11.3.0 +isPrefixOf :: ShortByteString -> ShortByteString -> Bool +isPrefixOf sbs1 = \sbs2 -> do + let l1 = length sbs1 + l2 = length sbs2 + if | l1 == 0 -> True + | l2 < l1 -> False + | otherwise -> + let i = compareByteArraysOff (asBA sbs1) 0 (asBA sbs2) 0 l1 + in i == 0 + +-- | /O(n)/ The 'isSuffixOf' function takes two ShortByteStrings and returns 'True' +-- iff the first is a suffix of the second. +-- +-- The following holds: +-- +-- > isSuffixOf x y == reverse x `isPrefixOf` reverse y +-- +-- @since 0.11.3.0 +isSuffixOf :: ShortByteString -> ShortByteString -> Bool +isSuffixOf sbs1 = \sbs2 -> do + let l1 = length sbs1 + l2 = length sbs2 + if | l1 == 0 -> True + | l2 < l1 -> False + | otherwise -> + let i = compareByteArraysOff (asBA sbs1) 0 (asBA sbs2) (l2 - l1) l1 + in i == 0 + +-- | Break a string on a substring, returning a pair of the part of the +-- string prior to the match, and the rest of the string. +-- +-- The following relationships hold: +-- +-- > break (== c) l == breakSubstring (singleton c) l +-- +-- For example, to tokenise a string, dropping delimiters: +-- +-- > tokenise x y = h : if null t then [] else tokenise x (drop (length x) t) +-- > where (h,t) = breakSubstring x y +-- +-- To skip to the first occurrence of a string: +-- +-- > snd (breakSubstring x y) +-- +-- To take the parts of a string before a delimiter: +-- +-- > fst (breakSubstring x y) +-- +-- Note that calling `breakSubstring x` does some preprocessing work, so +-- you should avoid unnecessarily duplicating breakSubstring calls with the same +-- pattern. +-- +-- @since 0.11.3.0 +breakSubstring :: ShortByteString -- ^ String to search for + -> ShortByteString -- ^ String to search in + -> (ShortByteString, ShortByteString) -- ^ Head and tail of string broken at substring +breakSubstring pat = + case lp of + 0 -> (empty,) + 1 -> breakByte (head pat) + _ -> if lp * 8 <= finiteBitSize (0 :: Word) + then shift + else karpRabin + where + lp = length pat + karpRabin :: ShortByteString -> (ShortByteString, ShortByteString) + karpRabin src + | length src < lp = (src,empty) + | otherwise = search (rollingHash $ take lp src) lp + where + k = 2891336453 :: Word32 + rollingHash = foldl' (\h b -> h * k + fromIntegral b) 0 + hp = rollingHash pat + m = k ^ lp + get = fromIntegral . unsafeIndex src + search !hs !i + | hp == hs && pat == take lp b = u + | length src <= i = (src, empty) -- not found + | otherwise = search hs' (i + 1) + where + u@(_, b) = splitAt (i - lp) src + hs' = hs * k + + get i - + m * get (i - lp) + {-# INLINE karpRabin #-} + + shift :: ShortByteString -> (ShortByteString, ShortByteString) + shift !src + | length src < lp = (src, empty) + | otherwise = search (intoWord $ take lp src) lp + where + intoWord :: ShortByteString -> Word + intoWord = foldl' (\w b -> (w `shiftL` 8) .|. fromIntegral b) 0 + + wp = intoWord pat + mask' = (1 `shiftL` (8 * lp)) - 1 + search !w !i + | w == wp = splitAt (i - lp) src + | length src <= i = (src, empty) + | otherwise = search w' (i + 1) + where + b = fromIntegral (unsafeIndex src i) + w' = mask' .&. ((w `shiftL` 8) .|. b) + {-# INLINE shift #-} + + +-- -------------------------------------------------------------------- +-- Searching ShortByteString + +-- | /O(n)/ 'elem' is the 'ShortByteString' membership predicate. +-- +-- @since 0.11.3.0 +elem :: Word8 -> ShortByteString -> Bool +elem c = \sbs -> case elemIndex c sbs of Nothing -> False ; _ -> True + +-- | /O(n)/ 'filter', applied to a predicate and a ShortByteString, +-- returns a ShortByteString containing those characters that satisfy the +-- predicate. +-- +-- @since 0.11.3.0 +filter :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +filter k = \sbs -> let l = length sbs + in if | l <= 0 -> sbs + | otherwise -> createAndTrim' l $ \mba -> go mba (asBA sbs) l + where + go :: forall s. MutableByteArray s -- mutable output bytestring + -> ByteArray -- input bytestring + -> Int -- length of input bytestring + -> ST s Int + go !mba ba !l = go' 0 0 + where + go' :: Int -- bytes read + -> Int -- bytes written + -> ST s Int + go' !br !bw + | br >= l = return bw + | otherwise = do + let w = indexWord8Array ba br + if k w + then do + writeWord8Array mba bw w + go' (br+1) (bw+1) + else + go' (br+1) bw +{-# INLINE filter #-} + +-- | /O(n)/ The 'find' function takes a predicate and a ShortByteString, +-- and returns the first element in matching the predicate, or 'Nothing' +-- if there is no such element. +-- +-- > find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing +-- +-- @since 0.11.3.0 +find :: (Word8 -> Bool) -> ShortByteString -> Maybe Word8 +find f = \sbs -> case findIndex f sbs of + Just n -> Just (sbs `index` n) + _ -> Nothing +{-# INLINE find #-} + +-- | /O(n)/ The 'partition' function takes a predicate a ShortByteString and returns +-- the pair of ShortByteStrings with elements which do and do not satisfy the +-- predicate, respectively; i.e., +-- +-- > partition p bs == (filter p sbs, filter (not . p) sbs) +-- +-- @since 0.11.3.0 +partition :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +partition k = \sbs -> let len = length sbs + in if | len <= 0 -> (sbs, sbs) + | otherwise -> createAndTrim2 len len $ \mba1 mba2 -> go mba1 mba2 (asBA sbs) len + where + go :: forall s. + MutableByteArray s -- mutable output bytestring1 + -> MutableByteArray s -- mutable output bytestring2 + -> ByteArray -- input bytestring + -> Int -- length of input bytestring + -> ST s (Int, Int) -- (length mba1, length mba2) + go !mba1 !mba2 ba !l = go' 0 0 + where + go' :: Int -- bytes read + -> Int -- bytes written to bytestring 1 + -> ST s (Int, Int) -- (length mba1, length mba2) + go' !br !bw1 + | br >= l = return (bw1, br - bw1) + | otherwise = do + let w = indexWord8Array ba br + if k w + then do + writeWord8Array mba1 bw1 w + go' (br+1) (bw1+1) + else do + writeWord8Array mba2 (br - bw1) w + go' (br+1) bw1 + + +-- -------------------------------------------------------------------- +-- Indexing ShortByteString + +-- | /O(n)/ The 'elemIndex' function returns the index of the first +-- element in the given 'ShortByteString' which is equal to the query +-- element, or 'Nothing' if there is no such element. +-- +-- @since 0.11.3.0 +elemIndex :: Word8 -> ShortByteString -> Maybe Int +elemIndex c = \sbs@(SBS ba#) -> do + let l = length sbs + accursedUnutterablePerformIO $ do + !s <- c_elem_index ba# c (fromIntegral l) + return $! if s < 0 then Nothing else Just (fromIntegral s) + + +-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning +-- the indices of all elements equal to the query element, in ascending order. +-- +-- @since 0.11.3.0 +elemIndices :: Word8 -> ShortByteString -> [Int] +elemIndices k = findIndices (==k) + +-- | count returns the number of times its argument appears in the ShortByteString +-- +-- @since 0.11.3.0 +count :: Word8 -> ShortByteString -> Int +count w = \sbs@(SBS ba#) -> accursedUnutterablePerformIO $ + fromIntegral <$> BS.c_count_ba ba# (fromIntegral $ length sbs) w + +-- | /O(n)/ The 'findIndex' function takes a predicate and a 'ShortByteString' and +-- returns the index of the first element in the ShortByteString +-- satisfying the predicate. +-- +-- @since 0.11.3.0 +findIndex :: (Word8 -> Bool) -> ShortByteString -> Maybe Int +findIndex k = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = Nothing + | k (w n) = Just n + | otherwise = go (n + 1) + in go 0 +{-# INLINE findIndex #-} + + +-- | /O(n)/ The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending order. +-- +-- @since 0.11.3.0 +findIndices :: (Word8 -> Bool) -> ShortByteString -> [Int] +findIndices k = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = [] + | k (w n) = n : go (n + 1) + | otherwise = go (n + 1) + in go 0 + +------------------------------------------------------------------------ +-- Exported low level operations + +copyToPtr :: ShortByteString -- ^ source data + -> Int -- ^ offset into source + -> Ptr a -- ^ destination + -> Int -- ^ number of bytes to copy + -> IO () +copyToPtr src off dst len = + stToIO $ + copyByteArrayToAddr (asBA src) off dst len + +createFromPtr :: Ptr a -- ^ source data + -> Int -- ^ number of bytes to copy + -> IO ShortByteString +createFromPtr !ptr len = + stToIO $ do + mba <- newByteArray len + copyAddrToByteArray ptr mba 0 len + ShortByteString <$> unsafeFreezeByteArray mba + + +------------------------------------------------------------------------ +-- Primop wrappers + +indexCharArray :: ByteArray -> Int -> Char +indexCharArray (ByteArray ba#) (I# i#) = C# (indexCharArray# ba# i#) + +indexWord8Array :: ByteArray -> Int -> Word8 +indexWord8Array (ByteArray ba#) (I# i#) = W8# (indexWord8Array# ba# i#) + +#if HS_UNALIGNED_ByteArray_OPS_OK +indexWord8ArrayAsWord64 :: ByteArray -> Int -> Word64 +indexWord8ArrayAsWord64 (ByteArray ba#) (I# i#) = W64# (indexWord8ArrayAsWord64# ba# i#) +#endif + +newByteArray :: Int -> ST s (MutableByteArray s) +newByteArray len@(I# len#) = + assert (len >= 0) $ + ST $ \s -> case newByteArray# len# s of + (# s', mba# #) -> (# s', MutableByteArray mba# #) + +unsafeFreezeByteArray :: MutableByteArray s -> ST s ByteArray +unsafeFreezeByteArray (MutableByteArray mba#) = + ST $ \s -> case unsafeFreezeByteArray# mba# s of + (# s', ba# #) -> (# s', ByteArray ba# #) + +writeWord8Array :: MutableByteArray s -> Int -> Word8 -> ST s () +writeWord8Array (MutableByteArray mba#) (I# i#) (W8# w#) = + ST $ \s -> case writeWord8Array# mba# i# w# s of + s' -> (# s', () #) + +#if HS_UNALIGNED_ByteArray_OPS_OK +writeWord64Array :: MutableByteArray s -> Int -> Word64 -> ST s () +writeWord64Array (MutableByteArray mba#) (I# i#) (W64# w#) = + ST $ \s -> case writeWord64Array# mba# i# w# s of + s' -> (# s', () #) +#endif + +copyAddrToByteArray :: Ptr a -> MutableByteArray RealWorld -> Int -> Int -> ST RealWorld () +copyAddrToByteArray (Ptr src#) (MutableByteArray dst#) (I# dst_off#) (I# len#) = + ST $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of + s' -> (# s', () #) + +copyByteArrayToAddr :: ByteArray -> Int -> Ptr a -> Int -> ST RealWorld () +copyByteArrayToAddr (ByteArray src#) (I# src_off#) (Ptr dst#) (I# len#) = + ST $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of + s' -> (# s', () #) + +copyByteArray :: ByteArray -> Int -> MutableByteArray s -> Int -> Int -> ST s () +copyByteArray (ByteArray src#) (I# src_off#) (MutableByteArray dst#) (I# dst_off#) (I# len#) = + ST $ \s -> case copyByteArray# src# src_off# dst# dst_off# len# s of + s' -> (# s', () #) + +setByteArray :: MutableByteArray s -> Int -> Int -> Int -> ST s () +setByteArray (MutableByteArray dst#) (I# off#) (I# len#) (I# c#) = + ST $ \s -> case setByteArray# dst# off# len# c# s of + s' -> (# s', () #) + +copyMutableByteArray :: MutableByteArray s -> Int -> MutableByteArray s -> Int -> Int -> ST s () +copyMutableByteArray (MutableByteArray src#) (I# src_off#) (MutableByteArray dst#) (I# dst_off#) (I# len#) = + ST $ \s -> case copyMutableByteArray# src# src_off# dst# dst_off# len# s of + s' -> (# s', () #) + + +------------------------------------------------------------------------ +-- FFI imports +-- +compareByteArrays :: ByteArray -> ByteArray -> Int -> Int +compareByteArrays ba1 ba2 = compareByteArraysOff ba1 0 ba2 0 + +compareByteArraysOff :: ByteArray -- ^ array 1 + -> Int -- ^ offset for array 1 + -> ByteArray -- ^ array 2 + -> Int -- ^ offset for array 2 + -> Int -- ^ length to compare + -> Int -- ^ like memcmp +compareByteArraysOff (ByteArray ba1#) (I# ba1off#) (ByteArray ba2#) (I# ba2off#) (I# len#) = + I# (compareByteArrays# ba1# ba1off# ba2# ba2off# len#) + +------------------------------------------------------------------------ +-- Primop replacements + +copyAddrToByteArray# :: Addr# + -> MutableByteArray# RealWorld -> Int# + -> Int# + -> State# RealWorld -> State# RealWorld + +copyByteArrayToAddr# :: ByteArray# -> Int# + -> Addr# + -> Int# + -> State# RealWorld -> State# RealWorld + +copyByteArray# :: ByteArray# -> Int# + -> MutableByteArray# s -> Int# + -> Int# + -> State# s -> State# s + +copyAddrToByteArray# = GHC.Exts.copyAddrToByteArray# +copyByteArrayToAddr# = GHC.Exts.copyByteArrayToAddr# +copyByteArray# = GHC.Exts.copyByteArray# + +-- | /O(n)./ Construct a new @ShortByteString@ from a @CString@. The +-- resulting @ShortByteString@ is an immutable copy of the original +-- @CString@, and is managed on the Haskell heap. The original +-- @CString@ must be null terminated. +-- +-- @since 0.10.10.0 +packCString :: CString -> IO ShortByteString +packCString cstr = do + len <- BS.c_strlen cstr + packCStringLen (cstr, fromIntegral len) + +-- | /O(n)./ Construct a new @ShortByteString@ from a @CStringLen@. The +-- resulting @ShortByteString@ is an immutable copy of the original @CStringLen@. +-- The @ShortByteString@ is a normal Haskell value and will be managed on the +-- Haskell heap. +-- +-- @since 0.10.10.0 +packCStringLen :: CStringLen -> IO ShortByteString +packCStringLen (cstr, len) | len >= 0 = createFromPtr cstr len +packCStringLen (_, len) = + moduleErrorIO "packCStringLen" ("negative length: " ++ show len) + +-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a +-- null-terminated @CString@. The @CString@ is a copy and will be freed +-- automatically; it must not be stored or used after the +-- subcomputation finishes. +-- +-- @since 0.10.10.0 +useAsCString :: ShortByteString -> (CString -> IO a) -> IO a +useAsCString sbs action = + allocaBytes (l+1) $ \buf -> do + copyToPtr sbs 0 buf (fromIntegral l) + pokeByteOff buf l (0::Word8) + action buf + where l = length sbs + +-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a 'CStringLen'. +-- As for 'useAsCString' this function makes a copy of the original @ShortByteString@. +-- It must not be stored or used after the subcomputation finishes. +-- +-- Beware that this function does not add a terminating @\NUL@ byte at the end of 'CStringLen'. +-- If you need to construct a pointer to a null-terminated sequence, use 'useAsCString' +-- (and measure length independently if desired). +-- +-- @since 0.10.10.0 +useAsCStringLen :: ShortByteString -> (CStringLen -> IO a) -> IO a +useAsCStringLen sbs action = + allocaBytes l $ \buf -> do + copyToPtr sbs 0 buf (fromIntegral l) + action (buf, l) + where l = length sbs + +-- | /O(n)/ Check whether a 'ShortByteString' represents valid UTF-8. +-- +-- @since 0.11.3.0 +isValidUtf8 :: ShortByteString -> Bool +isValidUtf8 sbs@(SBS ba#) = accursedUnutterablePerformIO $ do + let n = length sbs + -- Use a safe FFI call for large inputs to avoid GC synchronization pauses + -- in multithreaded contexts. + -- This specific limit was chosen based on results of a simple benchmark, see: + -- https://github.com/haskell/bytestring/issues/451#issuecomment-991879338 + -- When changing this function, also consider changing the related function: + -- Data.ByteString.isValidUtf8 + i <- if n < 1000000 || not (isPinned ba#) + then cIsValidUtf8BA ba# (fromIntegral n) + else cIsValidUtf8BASafe ba# (fromIntegral n) + IO (\s -> (# touch# ba# s, () #)) + return $ i /= 0 + +-- --------------------------------------------------------------------- +-- Internal utilities + +moduleErrorIO :: HasCallStack => String -> String -> IO a +moduleErrorIO fun msg = throwIO . userError $ moduleErrorMsg fun msg +{-# NOINLINE moduleErrorIO #-} + +moduleErrorMsg :: String -> String -> String +moduleErrorMsg fun msg = "Data.ByteString.Short." ++ fun ++ ':':' ':msg + + +-- Find from the end of the string using predicate. +-- +-- Return '0' if the predicate returns false for the entire ShortByteString. +findFromEndUntil :: (Word8 -> Bool) -> ShortByteString -> Int +findFromEndUntil k sbs = go (length sbs - 1) + where + ba = asBA sbs + go !n | n < 0 = 0 + | k (indexWord8Array ba n) = n + 1 + | otherwise = go (n - 1) + +findIndexOrLength :: (Word8 -> Bool) -> ShortByteString -> Int +findIndexOrLength k sbs = go 0 + where + l = length sbs + ba = asBA sbs + go !n | n >= l = l + | k (indexWord8Array ba n) = n + | otherwise = go (n + 1) + + +packBytesRev :: [Word8] -> ShortByteString +packBytesRev cs = packLenBytesRev (List.length cs) cs + +packLenBytesRev :: Int -> [Word8] -> ShortByteString +packLenBytesRev len ws0 = + create len (\mba -> go mba len ws0) + where + go :: MutableByteArray s -> Int -> [Word8] -> ST s () + go !_ !_ [] = return () + go !mba !i (w:ws) = do + writeWord8Array mba (i - 1) w + go mba (i - 1) ws + + +breakByte :: Word8 -> ShortByteString -> (ShortByteString, ShortByteString) +breakByte c sbs = case elemIndex c sbs of + Nothing -> (sbs, empty) + Just n -> (take n sbs, drop n sbs) + +-- Common up near identical calls to `error' to reduce the number +-- constant strings created when compiled: +errorEmptySBS :: HasCallStack => String -> a +errorEmptySBS fun = moduleError fun "empty ShortByteString" +{-# NOINLINE errorEmptySBS #-} + +moduleError :: HasCallStack => String -> String -> a +moduleError fun msg = error (moduleErrorMsg fun msg) +{-# NOINLINE moduleError #-} + diff --git a/Data/ByteString/Unsafe.hs b/Data/ByteString/Unsafe.hs --- a/Data/ByteString/Unsafe.hs +++ b/Data/ByteString/Unsafe.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -#if __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Unsafe #-} -#endif -- | -- Module : Data.ByteString.Unsafe @@ -22,36 +18,35 @@ module Data.ByteString.Unsafe ( -- * Unchecked access - unsafeHead, -- :: ByteString -> Word8 - unsafeTail, -- :: ByteString -> ByteString - unsafeInit, -- :: ByteString -> ByteString - unsafeLast, -- :: ByteString -> Word8 - 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 - unsafePackMallocCStringLen, -- :: CStringLen -> IO ByteString + unsafePackCString, + unsafePackCStringLen, + unsafePackMallocCString, + unsafePackMallocCStringLen, - unsafePackAddress, -- :: Addr# -> IO ByteString - unsafePackAddressLen, -- :: Int -> Addr# -> IO ByteString - unsafePackCStringFinalizer, -- :: Ptr Word8 -> Int -> IO () -> IO ByteString - unsafeFinalize, -- :: ByteString -> IO () + unsafePackAddress, + unsafePackAddressLen, + unsafePackCStringFinalizer, + unsafeFinalize, ) where import Data.ByteString.Internal import Foreign.ForeignPtr (newForeignPtr_, newForeignPtr, withForeignPtr) -import Foreign.Ptr (Ptr, castPtr) import Foreign.Storable (Storable(..)) import Foreign.C.String (CString, CStringLen) @@ -63,8 +58,8 @@ import qualified Foreign.ForeignPtr as FC (finalizeForeignPtr) import qualified Foreign.Concurrent as FC (newForeignPtr) -import GHC.Prim (Addr#) -import GHC.Ptr (Ptr(..)) +import GHC.Exts (Addr#) +import GHC.Ptr (Ptr(..), castPtr) -- --------------------------------------------------------------------- -- @@ -76,7 +71,7 @@ -- to provide a proof that the ByteString is non-empty. unsafeHead :: ByteString -> Word8 unsafeHead (BS x l) = assert (l > 0) $ - accursedUnutterablePerformIO $ withForeignPtr x $ \p -> peek p + accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> peek p {-# INLINE unsafeHead #-} -- | A variety of 'tail' for non-empty ByteStrings. 'unsafeTail' omits the @@ -98,7 +93,7 @@ -- provide a separate proof that the ByteString is non-empty. unsafeLast :: ByteString -> Word8 unsafeLast (BS x l) = assert (l > 0) $ - accursedUnutterablePerformIO $ withForeignPtr x $ \p -> peekByteOff p (l-1) + accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> peekByteOff p (l-1) {-# INLINE unsafeLast #-} -- | Unsafe 'ByteString' index (subscript) operator, starting from 0, returning a 'Word8' @@ -107,7 +102,7 @@ -- other way. unsafeIndex :: ByteString -> Int -> Word8 unsafeIndex (BS x l) i = assert (i >= 0 && i < l) $ - accursedUnutterablePerformIO $ withForeignPtr x $ \p -> peekByteOff p i + accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> peekByteOff p i {-# INLINE unsafeIndex #-} -- | A variety of 'take' which omits the checks on @n@ so there is an @@ -265,7 +260,8 @@ -- after this. -- unsafeUseAsCString :: ByteString -> (CString -> IO a) -> IO a -unsafeUseAsCString (BS ps _) ac = withForeignPtr ps $ \p -> ac (castPtr p) +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'. @@ -284,4 +280,5 @@ -- -- If 'Data.ByteString.empty' is given, it will pass @('Foreign.Ptr.nullPtr', 0)@. unsafeUseAsCStringLen :: ByteString -> (CStringLen -> IO a) -> IO a -unsafeUseAsCStringLen (BS ps l) f = withForeignPtr ps $ \p -> f (castPtr p,l) +unsafeUseAsCStringLen (BS ps l) action = withForeignPtr ps $ \p -> action (castPtr p, l) +-- Cannot use unsafeWithForeignPtr, because action can diverge diff --git a/Data/ByteString/Utils/ByteOrder.hs b/Data/ByteString/Utils/ByteOrder.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Utils/ByteOrder.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} + +#include "MachDeps.h" + +-- | Why does this module exist? There is "GHC.ByteOrder" in base. +-- But that module is /broken/ until base-4.14/ghc-8.10, so we +-- can't rely on it until we drop support for older ghcs. +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/20338 +-- and https://gitlab.haskell.org/ghc/ghc/-/issues/18445 + +module Data.ByteString.Utils.ByteOrder + ( ByteOrder(..) + , hostByteOrder + , whenLittleEndian + , whenBigEndian + ) where + +import GHC.ByteOrder (ByteOrder(..)) + +hostByteOrder :: ByteOrder +hostByteOrder = +#ifdef WORDS_BIGENDIAN + BigEndian +#else + LittleEndian +#endif + +-- | If the host is little-endian, applies the given function to the given arg. +-- If the host is big-endian, returns the second argument unchanged. +whenLittleEndian :: (a -> a) -> a -> a +whenLittleEndian fun val = case hostByteOrder of + LittleEndian -> fun val + BigEndian -> val + +-- | If the host is little-endian, returns the second argument unchanged. +-- If the host is big-endian, applies the given function to the given arg. +whenBigEndian :: (a -> a) -> a -> a +whenBigEndian fun val = case hostByteOrder of + LittleEndian -> val + BigEndian -> fun val diff --git a/Data/ByteString/Utils/UnalignedAccess.hs b/Data/ByteString/Utils/UnalignedAccess.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Utils/UnalignedAccess.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE CPP #-} + +#include "bytestring-cpp-macros.h" + +-- | +-- Module : Data.ByteString.Utils.UnalignedAccess +-- Copyright : (c) Matthew Craven 2023-2024 +-- License : BSD-style +-- Maintainer : clyring@gmail.com +-- Stability : internal +-- Portability : non-portable +-- +-- Primitives for reading and writing at potentially-unaligned memory locations + +module Data.ByteString.Utils.UnalignedAccess + ( unalignedWriteU16 + , unalignedWriteU32 + , unalignedWriteU64 + , unalignedWriteFloat + , unalignedWriteDouble + , unalignedReadU64 + ) where + +import Foreign.Ptr +import Data.Word + + +#if HS_UNALIGNED_ADDR_PRIMOPS_AVAILABLE +import GHC.IO (IO(..)) +import GHC.Word (Word16(..), Word32(..), Word64(..)) +import GHC.Exts + +unalignedWriteU16 :: Word16 -> Ptr Word8 -> IO () +unalignedWriteU16 = coerce $ \(W16# x#) (Ptr p#) s + -> (# writeWord8OffAddrAsWord16# p# 0# x# s, () #) + +unalignedWriteU32 :: Word32 -> Ptr Word8 -> IO () +unalignedWriteU32 = coerce $ \(W32# x#) (Ptr p#) s + -> (# writeWord8OffAddrAsWord32# p# 0# x# s, () #) + +unalignedWriteU64 :: Word64 -> Ptr Word8 -> IO () +unalignedWriteU64 = coerce $ \(W64# x#) (Ptr p#) s + -> (# writeWord8OffAddrAsWord64# p# 0# x# s, () #) + +unalignedWriteFloat :: Float -> Ptr Word8 -> IO () +unalignedWriteFloat = coerce $ \(F# x#) (Ptr p#) s + -> (# writeWord8OffAddrAsFloat# p# 0# x# s, () #) + +unalignedWriteDouble :: Double -> Ptr Word8 -> IO () +unalignedWriteDouble = coerce $ \(D# x#) (Ptr p#) s + -> (# writeWord8OffAddrAsDouble# p# 0# x# s, () #) + +unalignedReadU64 :: Ptr Word8 -> IO Word64 +unalignedReadU64 = coerce $ \(Ptr p#) s + -> case readWord8OffAddrAsWord64# p# 0# s of + (# s', w64# #) -> (# s', W64# w64# #) + +#elif HS_UNALIGNED_POKES_OK +import Foreign.Storable + +unalignedWriteU16 :: Word16 -> Ptr Word8 -> IO () +unalignedWriteU16 x p = poke (castPtr p) x + +unalignedWriteU32 :: Word32 -> Ptr Word8 -> IO () +unalignedWriteU32 x p = poke (castPtr p) x + +unalignedWriteU64 :: Word64 -> Ptr Word8 -> IO () +unalignedWriteU64 x p = poke (castPtr p) x + +unalignedWriteFloat :: Float -> Ptr Word8 -> IO () +unalignedWriteFloat x p = poke (castPtr p) x + +unalignedWriteDouble :: Double -> Ptr Word8 -> IO () +unalignedWriteDouble x p = poke (castPtr p) x + +unalignedReadU64 :: Ptr Word8 -> IO Word64 +unalignedReadU64 p = peek (castPtr p) + +#else +foreign import ccall unsafe "static fpstring.h fps_unaligned_write_u16" + unalignedWriteU16 :: Word16 -> Ptr Word8 -> IO () +foreign import ccall unsafe "static fpstring.h fps_unaligned_write_u32" + unalignedWriteU32 :: Word32 -> Ptr Word8 -> IO () +foreign import ccall unsafe "static fpstring.h fps_unaligned_write_u64" + unalignedWriteU64 :: Word64 -> Ptr Word8 -> IO () +foreign import ccall unsafe "static fpstring.h fps_unaligned_write_HsFloat" + unalignedWriteFloat :: Float -> Ptr Word8 -> IO () +foreign import ccall unsafe "static fpstring.h fps_unaligned_write_HsDouble" + unalignedWriteDouble :: Double -> Ptr Word8 -> IO () +foreign import ccall unsafe "static fpstring.h fps_unaligned_read_u64" + unalignedReadU64 :: Ptr Word8 -> IO Word64 +#endif + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -2,6 +2,7 @@ (c) Duncan Coutts 2006-2015 (c) David Roundy 2003-2005 (c) Simon Meier 2010-2011 + (c) Koz Ross 2021 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # ByteString: Fast, Packed Strings of Bytes -[![Build Status](https://github.com/haskell/bytestring/workflows/ci/badge.svg)](https://github.com/haskell/bytestring/actions?query=workflow%3Aci) [![Hackage](http://img.shields.io/hackage/v/bytestring.svg)](https://hackage.haskell.org/package/bytestring) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/bytestring/badge)](https://matrix.hackage.haskell.org/package/bytestring) [![Stackage LTS](http://stackage.org/package/bytestring/badge/lts)](http://stackage.org/lts/package/bytestring) [![Stackage Nightly](http://stackage.org/package/bytestring/badge/nightly)](http://stackage.org/nightly/package/bytestring) +[![Build Status](https://github.com/haskell/bytestring/workflows/ci/badge.svg)](https://github.com/haskell/bytestring/actions?query=workflow%3Aci) [![Hackage](http://img.shields.io/hackage/v/bytestring.svg)](https://hackage.haskell.org/package/bytestring) [![Stackage LTS](http://stackage.org/package/bytestring/badge/lts)](http://stackage.org/lts/package/bytestring) [![Stackage Nightly](http://stackage.org/package/bytestring/badge/nightly)](http://stackage.org/nightly/package/bytestring) This library provides the `Data.ByteString` module -- strict and lazy byte arrays manipulable as strings -- providing very time/space-efficient @@ -15,8 +15,8 @@ Requirements: - * Cabal 1.10 or greater - * GHC 7.0 or greater + * Cabal 2.2 or greater + * GHC 8.4 or greater ### Authors diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -7,40 +7,45 @@ -- Portability : tested on GHC only -- -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MagicHash #-} - 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 Data.ByteString.Builder.Extra (byteStringCopy, - byteStringInsert, - intHost) -import Data.ByteString.Builder.Internal (ensureFree) +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 @@ -92,6 +97,15 @@ 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 @@ -110,16 +124,46 @@ -- benchmark wrappers --------------------- -{-# INLINE benchB #-} benchB :: String -> a -> (a -> Builder) -> Benchmark -benchB name x b = - bench (name ++" (" ++ show nRepl ++ ")") $ - whnf (L.length . toLazyByteString . b) x +{-# INLINE benchB #-} +benchB name x b = benchB' (name ++" (" ++ show nRepl ++ ")") x b -{-# INLINE benchB' #-} benchB' :: String -> a -> (a -> Builder) -> Benchmark -benchB' name x b = bench name $ whnf (L.length . toLazyByteString . b) x +{-# 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 @@ -214,22 +258,15 @@ -- benchmarks ------------- -sanityCheckInfo :: [String] -sanityCheckInfo = - [ "Sanity checks:" - , " lengths of input data: " ++ show - [ length intData, length floatData, length doubleData - , length smallIntegerData, length largeIntegerData - , S.length byteStringData, fromIntegral (L.length lazyByteStringData) - ] - ] - sortInputs :: [S.ByteString] sortInputs = map (`S.take` S.pack [122, 121 .. 32]) [10..25] foldInputs :: [S.ByteString] foldInputs = map (\k -> S.pack $ if k <= 6 then take (2 ^ k) [32..95] else concat (replicate (2 ^ (k - 6)) [32..95])) [0..16] +foldInputsLazy :: [L.ByteString] +foldInputsLazy = map (\k -> L.pack $ if k <= 6 then take (2 ^ k) [32..95] else concat (replicate (2 ^ (k - 6)) [32..95])) [0..16] + zeroes :: L.ByteString zeroes = L.replicate 10000 0 @@ -243,19 +280,53 @@ smallTraversalInput :: S.ByteString smallTraversalInput = S8.pack "The quick brown fox" +asciiBuf, utf8Buf, halfNullBuf, allNullBuf :: Ptr Word8 +asciiBuf = Ptr "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"# +utf8Buf = Ptr "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\xc0\x80xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"# +halfNullBuf = Ptr "\xc0\x80xx\xc0\x80x\xc0\x80\xc0\x80x\xc0\x80\xc0\x80xx\xc0\x80\xc0\x80xxx\xc0\x80x\xc0\x80x\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80xxx\xc0\x80x\xc0\x80xx\xc0\x80\xc0\x80xxxxxxxxxx\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80x\xc0\x80\xc0\x80x\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80xxx"# +allNullBuf = Ptr "\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80"# + +asciiLit, utf8Lit :: Ptr Word8 -> Builder +asciiLit (Ptr p#) = P.cstring p# +utf8Lit (Ptr p#) = P.cstringUtf8 p# + +asciiStr, utf8Str :: String +asciiStr = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" +utf8Str = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\0xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" + main :: IO () main = do - mapM_ putStrLn sanityCheckInfo defaultMain [ bgroup "Data.ByteString.Builder" [ bgroup "Small payload" - [ benchB' "mempty" () (const mempty) - , benchB' "ensureFree 8" () (const (ensureFree 8)) - , benchB' "intHost 1" 1 intHost - , benchB' "UTF-8 String (naive)" "hello world\0" fromString - , benchB' "UTF-8 String" () $ \() -> P.cstringUtf8 "hello world\0"# - , benchB' "String (naive)" "hello world!" fromString - , benchB' "String" () $ \() -> P.cstring "hello world!"# + [ 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" @@ -271,15 +342,12 @@ P.primMapLazyByteStringFixed P.word8 ] , bgroup "ByteString insertion" $ - let dataName = " byteStringChunks" ++ - show (S.length (head byteStringChunksData)) ++ "Data" - in - [ benchB ("foldMap byteStringInsert" ++ dataName) byteStringChunksData - (foldMap byteStringInsert) - , benchB ("foldMap byteString" ++ dataName) byteStringChunksData + [ benchB "foldMap byteStringInsert" byteStringChunksData + (foldMap Extra.byteStringInsert) + , benchB "foldMap byteString" byteStringChunksData (foldMap byteString) - , benchB ("foldMap byteStringCopy" ++ dataName) byteStringChunksData - (foldMap byteStringCopy) + , benchB "foldMap byteStringCopy" byteStringChunksData + (foldMap Extra.byteStringCopy) ] , bgroup "Non-bounded encodings" @@ -382,6 +450,11 @@ [ 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" @@ -405,26 +478,76 @@ , 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 "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 "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 "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 @@ -444,10 +567,17 @@ , bench "elemIndexInd" $ nf (S.elemIndexEnd 42) byteStringData ] , bgroup "traversals" - [ bench "map (+1)" $ nf (S.map (+ 1)) largeTraversalInput - , bench "map (+1)" $ nf (S.map (+ 1)) smallTraversalInput + [ bench "map (+1) large" $ nf (S.map (+ 1)) largeTraversalInput + , bench "map (+1) small" $ nf (S.map (+ 1)) smallTraversalInput ] + , bgroup "unlines" + [ bench "lazy" $ nf L8.unlines (map (L8.pack . show) intData) + , bench "strict" $ nf S8.unlines (map (S8.pack . show) intData) + ] , benchBoundsCheckFusion + , benchCount , benchCSV , benchIndices + , benchReadInt + , benchShort ] diff --git a/bench/BenchBoundsCheckFusion.hs b/bench/BenchBoundsCheckFusion.hs --- a/bench/BenchBoundsCheckFusion.hs +++ b/bench/BenchBoundsCheckFusion.hs @@ -8,8 +8,6 @@ -- -- Benchmark that the bounds checks fuse. -{-# LANGUAGE PackageImports, ScopedTypeVariables, BangPatterns #-} - module BenchBoundsCheckFusion (benchBoundsCheckFusion) where import Prelude hiding (words) diff --git a/bench/BenchCSV.hs b/bench/BenchCSV.hs --- a/bench/BenchCSV.hs +++ b/bench/BenchCSV.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- | -- Copyright : (c) 2010-2011 Simon Meier -- License : BSD3-style (see LICENSE) @@ -9,14 +11,11 @@ -- Running example for documentation of Data.ByteString.Builder -- -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - module BenchCSV (benchCSV) where --- ************************************************************************** +-- ************************************************************************** -- CamHac 2011: An introduction to Data.ByteString.Builder --- ************************************************************************** +-- ************************************************************************** {- The Encoding Problem @@ -122,9 +121,6 @@ import Data.ByteString.Builder.Prim.Internal ( (>*<), (>$<) ) import qualified Data.ByteString.Builder.Prim as E --- To be used in a later comparison -import qualified Data.DList as D - -- 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 @@ -136,6 +132,12 @@ 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 ------------------------------------------------------------------------------ @@ -334,6 +336,8 @@ -- Difference-list based rendering ------------------------------------------------------------------------------ +#ifdef MIN_VERSION_dlist + type DString = D.DList Char renderStringD :: String -> DString @@ -360,6 +364,8 @@ benchDListUtf8 = bench "utf8 + renderTableD maxiTable" $ nf (L.length . B.toLazyByteString . B.stringUtf8 . D.toList . renderTableD) maxiTable +#endif + ------------------------------------------------------------------------------ -- Text Builder ------------------------------------------------------------------------------ @@ -406,7 +412,9 @@ [ benchNF , benchString , benchStringUtf8 +#ifdef MIN_VERSION_dlist , benchDListUtf8 +#endif #ifdef MIN_VERSION_text , benchTextBuilder , benchTextBuilderUtf8 diff --git a/bench/BenchCount.hs b/bench/BenchCount.hs new file mode 100644 --- /dev/null +++ b/bench/BenchCount.hs @@ -0,0 +1,29 @@ +-- | +-- Copyright : (c) 2021 Georg Rudoy +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Georg Rudoy <0xd34df00d+github@gmail.com> +-- +-- Benchmark count + +module BenchCount (benchCount) where + +import Test.Tasty.Bench +import qualified Data.ByteString.Char8 as B + +benchCount :: Benchmark +benchCount = bgroup "Count" + [ bgroup "no matches, same char" $ mkBenches (1 : commonSizes) (\s -> B.replicate s 'b') + , bgroup "no matches, different chars" $ mkBenches commonSizes (\s -> genCyclic 10 s 'b') + , bgroup "some matches, alternating" $ mkBenches commonSizes (\s -> genCyclic 2 s 'a') + , bgroup "some matches, short cycle" $ mkBenches commonSizes (\s -> genCyclic 5 s 'a') + , bgroup "some matches, long cycle" $ mkBenches commonSizes (\s -> genCyclic 10 s 'a') + , bgroup "all matches" $ mkBenches (1 : commonSizes) (\s -> B.replicate s 'a') + ] + where + aboveSimdSwitchThreshold = 1030 -- something above the threshold of 1024 that's divisible by cycle lengths + commonSizes = [ 10, 100, 1000, aboveSimdSwitchThreshold, 10000, 100000, 1000000 ] + mkBenches sizes gen = [ bench (show size ++ " chars long") $ nf (B.count 'a') (gen size) + | size <- sizes + ] + genCyclic cycleLen size from = B.concat $ replicate (size `div` cycleLen) $ B.pack (take cycleLen [from..]) diff --git a/bench/BenchIndices.hs b/bench/BenchIndices.hs --- a/bench/BenchIndices.hs +++ b/bench/BenchIndices.hs @@ -6,8 +6,6 @@ -- -- Benchmark elemIndex, findIndex, elemIndices, and findIndices -{-# LANGUAGE BangPatterns #-} - module BenchIndices (benchIndices) where import Data.Foldable (foldMap) @@ -15,7 +13,7 @@ import Data.Monoid import Data.String import Test.Tasty.Bench -import Prelude hiding (words) +import Prelude hiding (words, head, tail) import Data.Word (Word8) import qualified Data.ByteString as S @@ -38,15 +36,15 @@ -- lines of 200 letters from a to e, followed by repeated letter f absurdlong :: S.ByteString -absurdlong = S.replicate 200 0x61 <> S.singleton nl +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 200 0x65 <> S.singleton nl) <> S.replicate 999999 0x66 benchIndices :: Benchmark -benchIndices = bgroup "Indices" +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 @@ -54,8 +52,8 @@ , bench "ElemIndex" $ nf (S.elemIndex nl) absurdlong ] , bgroup "ByteString strict second index" $ - [ bench "FindIndices" $ nf (listToMaybe . tail . S.findIndices (== nl)) absurdlong - , bench "ElemIndices" $ nf (listToMaybe . tail . S.elemIndices nl) absurdlong + [ 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 ] diff --git a/bench/BenchReadInt.hs b/bench/BenchReadInt.hs new file mode 100644 --- /dev/null +++ b/bench/BenchReadInt.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Copyright : (c) 2021 Viktor Dukhovni +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Viktor Dukhovni +-- +-- Benchmark readInt and variants, readWord and variants, +-- readInteger and readNatural + +module BenchReadInt (benchReadInt) where + +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Test.Tasty.Bench +import Data.Int +import Data.Word +import Numeric.Natural +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup (Semigroup((<>))) +#endif +import Data.Monoid (mconcat) + +------------------------------------------------------------------------------ +-- Benchmark +------------------------------------------------------------------------------ + +-- Sum space-separated integers in a ByteString. +loopS :: Integral a + => (S.ByteString -> Maybe (a, S.ByteString)) -> S.ByteString -> a +loopS rd = go 0 + where + go !acc !bs = case rd bs of + Just (i, t) -> case S.uncons t of + Just (_, t') -> go (acc + i) t' + Nothing -> acc + i + Nothing -> acc + +-- Sum space-separated integers in a ByteString. +loopL :: Integral a + => (L.ByteString -> Maybe (a, L.ByteString)) -> L.ByteString -> a +loopL rd = go 0 + where + go !acc !bs = case rd bs of + Just (i, t) -> case L.uncons t of + Just (_, t') -> go (acc + i) t' + Nothing -> acc + i + Nothing -> acc + +benchReadInt :: Benchmark +benchReadInt = bgroup "Read Integral" + [ bgroup "Strict" + [ bench "ReadInt" $ nf (loopS S.readInt) intS + , bench "ReadInt8" $ nf (loopS S.readInt8) int8S + , bench "ReadInt16" $ nf (loopS S.readInt16) int16S + , bench "ReadInt32" $ nf (loopS S.readInt32) int32S + , bench "ReadInt64" $ nf (loopS S.readInt64) int64S + , bench "ReadWord" $ nf (loopS S.readWord) wordS + , bench "ReadWord8" $ nf (loopS S.readWord8) word8S + , bench "ReadWord16" $ nf (loopS S.readWord16) word16S + , bench "ReadWord32" $ nf (loopS S.readWord32) word32S + , bench "ReadWord64" $ nf (loopS S.readWord64) word64S + , bench "ReadInteger" $ nf (loopS S.readInteger) bignatS + , bench "ReadNatural" $ nf (loopS S.readNatural) bignatS + , bench "ReadInteger small" $ nf (loopS S.readInteger) intS + , bench "ReadNatural small" $ nf (loopS S.readNatural) wordS + ] + + , bgroup "Lazy" + [ bench "ReadInt" $ nf (loopL L.readInt) intL + , bench "ReadInt8" $ nf (loopL L.readInt8) int8L + , bench "ReadInt16" $ nf (loopL L.readInt16) int16L + , bench "ReadInt32" $ nf (loopL L.readInt32) int32L + , bench "ReadInt64" $ nf (loopL L.readInt64) int64L + , bench "ReadWord" $ nf (loopL L.readWord) wordL + , bench "ReadWord8" $ nf (loopL L.readWord8) word8L + , bench "ReadWord16" $ nf (loopL L.readWord16) word16L + , bench "ReadWord32" $ nf (loopL L.readWord32) word32L + , bench "ReadWord64" $ nf (loopL L.readWord64) word64L + , bench "ReadInteger" $ nf (loopL L.readInteger) bignatL + , bench "ReadNatural" $ nf (loopL L.readNatural) bignatL + , bench "ReadInteger small" $ nf (loopL L.readInteger) intL + , bench "ReadNatural small" $ nf (loopL L.readNatural) wordL + ] + ] + where + mkWordL :: forall a. (Integral a, Bounded a) + => (a -> B.Builder) -> L.ByteString + mkWordL f = B.toLazyByteString b + where b = mconcat [f i <> B.char8 ' ' | i <- [n-255..n]] + n = maxBound @a + mkWordS f = S.toStrict $ mkWordL f + + mkIntL :: forall a. (Integral a, Bounded a) + => (a -> B.Builder) -> L.ByteString + mkIntL f = B.toLazyByteString b + where b = mconcat [f (i + 128) <> B.char8 ' ' | i <- [n-255..n]] + n = maxBound @a + mkIntS f = S.toStrict $ mkIntL f + + wordS, word8S, word16S, word32S, word64S :: S.ByteString + !wordS = mkWordS B.wordDec + !word8S = mkWordS B.word8Dec + !word16S = mkWordS B.word16Dec + !word32S = mkWordS B.word32Dec + !word64S = mkWordS B.word64Dec + + intS, int8S, int16S, int32S, int64S :: S.ByteString + !intS = mkIntS B.intDec + !int8S = mkIntS B.int8Dec + !int16S = mkIntS B.int16Dec + !int32S = mkIntS B.int32Dec + !int64S = mkIntS B.int64Dec + + word8L, word16L, word32L, word64L :: L.ByteString + !wordL = mkWordL B.wordDec + !word8L = mkWordL B.word8Dec + !word16L = mkWordL B.word16Dec + !word32L = mkWordL B.word32Dec + !word64L = mkWordL B.word64Dec + + intL, int8L, int16L, int32L, int64L :: L.ByteString + !intL = mkIntL B.intDec + !int8L = mkIntL B.int8Dec + !int16L = mkIntL B.int16Dec + !int32L = mkIntL B.int32Dec + !int64L = mkIntL B.int64Dec + + bignatL :: L.ByteString + !bignatL = B.toLazyByteString b + where b = mconcat [B.integerDec (powpow i) <> B.char8 ' ' | i <- [0..13]] + powpow :: Word -> Integer + powpow n = 2^(2^n :: Word) + + bignatS :: S.ByteString + !bignatS = S.toStrict bignatL diff --git a/bench/BenchShort.hs b/bench/BenchShort.hs new file mode 100644 --- /dev/null +++ b/bench/BenchShort.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE OverloadedStrings #-} + +module BenchShort (benchShort) where + +import Control.DeepSeq (force) +import Data.Foldable (foldMap) +import Data.Maybe (listToMaybe) +import Data.Monoid +import Data.String +import Test.Tasty.Bench +import Prelude hiding (words, head, tail) + +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as S + +import Data.ByteString.Builder +import Data.ByteString.Builder.Extra (byteStringCopy, + byteStringInsert, + intHost) +import Data.ByteString.Builder.Internal (ensureFree) +import Data.ByteString.Builder.Prim (BoundedPrim, FixedPrim, + (>$<)) +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Builder.Prim.Internal as PI + +import Foreign + +import System.Random + + + +------------------------------------------------------------------------------ +-- Benchmark +------------------------------------------------------------------------------ + +-- input data (NOINLINE to ensure memoization) +---------------------------------------------- + +-- | Few-enough repetitions to avoid making GC too expensive. +nRepl :: Int +nRepl = 10000 + +{-# NOINLINE intData #-} +intData :: [Int] +intData = [1..nRepl] + +{-# NOINLINE byteStringData #-} +byteStringData :: S.ShortByteString +byteStringData = S.pack $ map fromIntegral intData + +{-# NOINLINE loremIpsum #-} +loremIpsum :: S.ShortByteString +loremIpsum = mconcat + [ " Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor" + , "incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis" + , "nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat." + , "Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu" + , "fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in" + , "culpa qui officia deserunt mollit anim id est laborum." + ] + +-- benchmark wrappers +--------------------- + +{-# INLINE benchB' #-} +benchB' :: String -> a -> (a -> ShortByteString) -> Benchmark +benchB' name x b = bench name $ whnf (S.length . b) x + + +-- We use this construction of just looping through @n,n-1,..,1@ to ensure that +-- we measure the speed of the encoding and not the speed of generating the +-- values to be encoded. +{-# INLINE benchIntEncodingB #-} +benchIntEncodingB :: Int -- ^ Maximal 'Int' to write + -> BoundedPrim Int -- ^ 'BoundedPrim' to execute + -> IO () -- ^ 'IO' action to benchmark +benchIntEncodingB n0 w + | n0 <= 0 = return () + | otherwise = do + fpbuf <- mallocForeignPtrBytes (n0 * PI.sizeBound w) + withForeignPtr fpbuf (loop n0) >> return () + where + loop !n !op + | n <= 0 = return op + | otherwise = PI.runB w n op >>= loop (n - 1) + + +-- Helpers +------------- + +hashInt :: Int -> Int +hashInt x = iterate step x !! 10 + where + step a = e + where b = (a `xor` 61) `xor` (a `shiftR` 16) + c = b + (b `shiftL` 3) + d = c `xor` (c `shiftR` 4) + e = d * 0x27d4eb2d + f = e `xor` (e `shiftR` 15) + +w :: Int -> Word8 +w = fromIntegral + +hashWord8 :: Word8 -> Word8 +hashWord8 = fromIntegral . hashInt . fromIntegral + +foldInputs' :: [[Word8]] +foldInputs' = force (S.unpack <$> foldInputs) + +foldInputs :: [S.ShortByteString] +foldInputs = map (\k -> S.pack $ if k <= 6 then take (2 ^ k) [32..95] else concat (replicate (2 ^ (k - 6)) [32..95])) [0..16] + +largeTraversalInput :: S.ShortByteString +largeTraversalInput = S.concat (replicate 10 byteStringData) + +smallTraversalInput :: S.ShortByteString +smallTraversalInput = "The quick brown fox" + +zeroes :: S.ShortByteString +zeroes = S.replicate 10000 0 + +partitionStrict p = nf (S.partition p) . randomStrict $ mkStdGen 98423098 + where randomStrict = fst . S.unfoldrN 10000 (Just . random) + +-- ASCII \n to ensure no typos +nl :: Word8 +nl = 0xa +{-# INLINE nl #-} + +-- non-inlined equality test +nilEq :: Word8 -> Word8 -> Bool +{-# NOINLINE nilEq #-} +nilEq = (==) + +-- lines of 200 letters from a to e, followed by repeated letter f +absurdlong :: S.ShortByteString +absurdlong = (S.replicate 200 0x61 <> S.singleton nl + <> S.replicate 200 0x62 <> S.singleton nl + <> S.replicate 200 0x63 <> S.singleton nl + <> S.replicate 200 0x64 <> S.singleton nl + <> S.replicate 200 0x65 <> S.singleton nl) + <> S.replicate 999999 0x66 + +bench_find_index_second :: ShortByteString -> Maybe Int +bench_find_index_second bs = + let isNl = (== nl) + in case S.findIndex isNl bs of + Just !i -> S.findIndex isNl (S.drop (i+1) bs) + Nothing -> Nothing +{-# INLINE bench_find_index_second #-} + +bench_elem_index_second :: ShortByteString -> Maybe Int +bench_elem_index_second bs = + case S.elemIndex nl bs of + Just !i -> S.elemIndex nl (S.drop (i+1) bs) + Nothing -> Nothing +{-# INLINE bench_elem_index_second #-} + + + +-- benchmarks +------------- + +benchShort :: Benchmark +benchShort = absurdlong `seq` bgroup "ShortByteString" + [ bgroup "Small payload" + [ benchB' "mempty" () (const mempty) + , benchB' "UTF-8 String (naive)" "hello world\0" fromString + , benchB' "String (naive)" "hello world!" fromString + ] + , bgroup "intercalate" + [ bench "intercalate (large)" $ whnf (S.intercalate $ " and also ") (replicate 300 "expression") + , bench "intercalate (small)" $ whnf (S.intercalate "&") (replicate 30 "foo") + , bench "intercalate (tiny)" $ whnf (S.intercalate "&") (["foo", "bar", "baz"]) + ] + , bgroup "partition" + [ + bgroup "strict" + [ + bench "mostlyTrueFast" $ partitionStrict (< (w 225)) + , bench "mostlyFalseFast" $ partitionStrict (< (w 10)) + , bench "balancedFast" $ partitionStrict (< (w 128)) + + , bench "mostlyTrueSlow" $ partitionStrict (\x -> hashWord8 x < w 225) + , bench "mostlyFalseSlow" $ partitionStrict (\x -> hashWord8 x < w 10) + , bench "balancedSlow" $ partitionStrict (\x -> hashWord8 x < w 128) + ] + ] + , bgroup "folds" + [ bgroup "strict" + [ bgroup "foldl" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldl (\acc x -> acc + fromIntegral x) (0 :: Int)) s) foldInputs + , bgroup "foldl'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldl' (\acc x -> acc + fromIntegral x) (0 :: Int)) s) foldInputs + , bgroup "foldr" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldr (\x acc -> fromIntegral x + acc) (0 :: Int)) s) foldInputs + , bgroup "foldr'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldr' (\x acc -> fromIntegral x + acc) (0 :: Int)) s) foldInputs + , bgroup "foldr1'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldr1' (\x acc -> fromIntegral x + acc)) s) foldInputs + , bgroup "unfoldrN" $ map (\s -> bench (show $ S.length s) $ + nf (S.unfoldrN (S.length s) (\a -> Just (a, a + 1))) 0) foldInputs + , bgroup "filter" $ map (\s -> bench (show $ S.length s) $ + nf (S.filter odd) s) foldInputs + ] + ] + , bgroup "findIndexOrLength" + [ bench "takeWhile" $ nf (S.takeWhile even) zeroes + , bench "dropWhile" $ nf (S.dropWhile even) zeroes + , bench "break" $ nf (S.break odd) zeroes + ] + , bgroup "findIndex_" + [ bench "findIndices" $ nf (sum . S.findIndices (\x -> x == 129 || x == 72)) byteStringData + , bench "find" $ nf (S.find (>= 198)) byteStringData + ] + , bgroup "traversals" + [ bench "map (+1) large" $ nf (S.map (+ 1)) largeTraversalInput + , bench "map (+1) small" $ nf (S.map (+ 1)) smallTraversalInput + ] + , bgroup "ShortByteString strict first index" $ + [ bench "FindIndices" $ nf (listToMaybe . S.findIndices (== nl)) absurdlong + , bench "ElemIndices" $ nf (listToMaybe . S.elemIndices nl) absurdlong + , bench "FindIndex" $ nf (S.findIndex (== nl)) absurdlong + , bench "ElemIndex" $ nf (S.elemIndex nl) absurdlong + ] + , bgroup "ShortByteString strict second index" $ + [ bench "FindIndices" $ nf (listToMaybe . drop 1 . S.findIndices (== nl)) absurdlong + , bench "ElemIndices" $ nf (listToMaybe . drop 1 . S.elemIndices nl) absurdlong + , bench "FindIndex" $ nf bench_find_index_second absurdlong + , bench "ElemIndex" $ nf bench_elem_index_second absurdlong + ] + , bgroup "ShortByteString index equality inlining" $ + [ bench "FindIndices/inlined" $ nf (S.findIndices (== nl)) absurdlong + , bench "FindIndices/non-inlined" $ nf (S.findIndices (nilEq nl)) absurdlong + , bench "FindIndex/inlined" $ nf (S.findIndex (== nl)) absurdlong + , bench "FindIndex/non-inlined" $ nf (S.findIndex (nilEq nl)) absurdlong + ] + , bgroup "ShortByteString conversions" $ + [ bgroup "unpack" $ map (\s -> bench (show $ S.length s) $ + nf (\x -> S.unpack x) s) foldInputs + , bgroup "pack" $ map (\s -> bench (show $ length s) $ + nf S.pack s) foldInputs' + , bench "unpack and get last element" $ nf (\x -> last . S.unpack $ x) absurdlong + , bench "unpack and get first 120 elements" $ nf (\x -> take 120 . S.unpack $ x) absurdlong + ] + ] diff --git a/bytestring.cabal b/bytestring.cabal --- a/bytestring.cabal +++ b/bytestring.cabal @@ -1,5 +1,7 @@ +Cabal-Version: 2.2 + Name: bytestring -Version: 0.11.1.0 +Version: 0.12.2.0 Synopsis: Fast, compact, strict and lazy byte strings with a list interface Description: An efficient compact, immutable byte string type (both strict and lazy) @@ -29,8 +31,9 @@ serialisation or pretty printing. . There is also a 'ShortByteString' type which has a lower memory overhead - and can can be converted to or from a 'ByteString', but supports very few - other operations. It is suitable for keeping many short strings in memory. + 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. @@ -40,7 +43,7 @@ . > import qualified Data.ByteString as BS -License: BSD3 +License: BSD-3-Clause License-file: LICENSE Category: Data Copyright: Copyright (c) Don Stewart 2005-2009, @@ -54,145 +57,197 @@ Maintainer: Haskell Bytestring Team , Core Libraries Committee Homepage: https://github.com/haskell/bytestring Bug-reports: https://github.com/haskell/bytestring/issues -Tested-With: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, - GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, - GHC==7.2.2, GHC==7.0.4 +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.10 -extra-source-files: README.md Changelog.md +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 -flag integer-simple - description: Use the simple integer library instead of GMP - default: False +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 >= 4.3 && < 5, ghc-prim, deepseq + import: language + build-depends: base >= 4.11 && < 5, ghc-prim, deepseq, template-haskell - 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 + if impl(ghc < 9.4) + build-depends: data-array-byte >= 0.1 && < 0.2 - Data.ByteString.Builder - Data.ByteString.Builder.Extra - Data.ByteString.Builder.Prim + 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 - -- perhaps only exposed temporarily - Data.ByteString.Builder.Internal - Data.ByteString.Builder.Prim.Internal - other-modules: - Data.ByteString.Builder.ASCII - Data.ByteString.Builder.Prim.Binary - Data.ByteString.Builder.Prim.ASCII - Data.ByteString.Builder.Prim.Internal.Floating - Data.ByteString.Builder.Prim.Internal.Base16 + Data.ByteString.Builder + Data.ByteString.Builder.Extra + Data.ByteString.Builder.Prim + Data.ByteString.Builder.RealFloat - default-language: Haskell2010 - other-extensions: CPP, - ForeignFunctionInterface, - BangPatterns - UnliftedFFITypes, - MagicHash, - UnboxedTuples, - DeriveDataTypeable - ScopedTypeVariables - RankNTypes - NamedFieldPuns --- if impl(ghc >= 7.2) --- other-extensions: Trustworthy, Unsafe - -- older ghc had issues with language pragmas guarded by cpp - if impl(ghc < 7) - default-extensions: CPP, MagicHash, UnboxedTuples, - DeriveDataTypeable, BangPatterns, - 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 - ghc-options: -Wall -fwarn-tabs - -O2 - -fmax-simplifier-iterations=10 - -fdicts-cheap - -fspec-constr-count=6 + 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 - cbits/itoa.c - include-dirs: include - includes: fpstring.h - install-includes: fpstring.h + 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 - -- flags for the decimal integer serialization code - if impl(ghc >= 8.11) - build-depends: ghc-bignum >= 1.0 + c-sources: cbits/fpstring.c + cbits/itoa.c + cbits/shortbytestring.c + cbits/aligned-static-hs-data.c - if impl(ghc >= 6.11) && impl(ghc < 8.11) - if !flag(integer-simple) - cpp-options: -DINTEGER_GMP - build-depends: integer-gmp >= 0.2 + if (arch(aarch64)) + c-sources: cbits/aarch64/is-valid-utf8.c + else + c-sources: cbits/is-valid-utf8.c - if impl(ghc >= 6.9) && impl(ghc < 6.11) - cpp-options: -DINTEGER_GMP - build-depends: integer >= 0.1 && < 0.2 + -- DNDEBUG disables asserts in cbits/ + cc-options: -std=c11 -DNDEBUG=1 + -fno-strict-aliasing + -Werror=undef -test-suite prop-compiled - type: exitcode-stdio-1.0 - main-is: Properties.hs - other-modules: Rules - QuickCheckUtils - hs-source-dirs: tests - build-depends: base, bytestring, ghc-prim, deepseq, - tasty, tasty-quickcheck - ghc-options: -fwarn-unused-binds - -threaded -rtsopts - default-language: Haskell2010 + -- 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 -test-suite lazy-hclose - type: exitcode-stdio-1.0 - main-is: LazyHClose.hs - hs-source-dirs: tests - build-depends: base, bytestring, ghc-prim, deepseq, - tasty, tasty-quickcheck - ghc-options: -fwarn-unused-binds - -threaded -rtsopts - default-language: Haskell2010 + 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 -test-suite test-builder + include-dirs: include + install-includes: fpstring.h + bytestring-cpp-macros.h + +test-suite bytestring-tests + import: language type: exitcode-stdio-1.0 - hs-source-dirs: tests/builder - main-is: TestSuite.hs - other-modules: Data.ByteString.Builder.Tests - Data.ByteString.Builder.Prim.Tests + main-is: Main.hs + other-modules: Builder Data.ByteString.Builder.Prim.TestUtils - build-depends: base, bytestring, ghc-prim, + 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, - dlist >= 0.5 && < 0.9, - transformers >= 0.3, + QuickCheck, tasty, - tasty-hunit, - tasty-quickcheck - if impl(ghc < 8.4) - build-depends: ghc-byteorder - ghc-options: -Wall -fwarn-tabs -threaded -rtsopts - default-language: Haskell2010 + tasty-quickcheck >= 0.8.1, + template-haskell, + transformers >= 0.3, + syb + ghc-options: -fwarn-unused-binds + -rtsopts + if !arch(wasm32) + ghc-options: -threaded + benchmark bytestring-bench + import: language main-is: BenchAll.hs other-modules: BenchBoundsCheckFusion + BenchCount BenchCSV BenchIndices + BenchReadInt + BenchShort type: exitcode-stdio-1.0 hs-source-dirs: bench - default-language: Haskell2010 - ghc-options: -O2 + + ghc-options: -O2 "-with-rtsopts=-A32m" + if impl(ghc >= 8.6) + ghc-options: -fproc-alignment=64 build-depends: base, bytestring, deepseq, - dlist, tasty-bench, random diff --git a/cbits/aarch64/is-valid-utf8.c b/cbits/aarch64/is-valid-utf8.c new file mode 100644 --- /dev/null +++ b/cbits/aarch64/is-valid-utf8.c @@ -0,0 +1,284 @@ +/* +Copyright (c) Koz Ross 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. +*/ +#pragma GCC push_options +#pragma GCC optimize("-O2") +#include +#include +#include +#include + +// Fallback (for tails). +static inline int is_valid_utf8_fallback(uint8_t const *const src, + size_t const len) { + uint8_t const *ptr = (uint8_t const *)src; + // This is 'one past the end' to make loop termination and bounds checks + // easier. + uint8_t const *const end = ptr + len; + while (ptr < end) { + uint8_t const byte = *ptr; + // Check if the byte is ASCII. + if (byte <= 0x7F) { + ptr++; + } + // Check for a valid 2-byte sequence. + // + // We use a signed comparison to avoid an extra comparison with 0x80, since + // _signed_ 0x80 is -128. + else if (ptr + 1 < end && byte >= 0xC2 && byte <= 0xDF && + ((int8_t) * (ptr + 1)) <= (int8_t)0xBF) { + ptr += 2; + } + // Check for a valid 3-byte sequence. + else if (ptr + 2 < end && byte >= 0xE0 && byte <= 0xEF) { + uint8_t const byte2 = *(ptr + 1); + bool byte2_valid = (int8_t)byte2 <= (int8_t)0xBF; + bool byte3_valid = ((int8_t) * (ptr + 2)) <= (int8_t)0xBF; + if (byte2_valid && byte3_valid && + // E0, A0..BF, 80..BF + ((byte == 0xE0 && byte2 >= 0xA0) || + // E1..EC, 80..BF, 80..BF + (byte >= 0xE1 && byte <= 0xEC) || + // ED, 80..9F, 80..BF + (byte == 0xED && byte2 <= 0x9F) || + // EE..EF, 80..BF, 80..BF + (byte >= 0xEE && byte <= 0xEF))) { + ptr += 3; + } else { + return 0; + } + } + // Check for a valid 4-byte sequence. + else if (ptr + 3 < end) { + uint8_t const byte2 = *(ptr + 1); + bool byte2_valid = (int8_t)byte2 <= (int8_t)0xBF; + bool byte3_valid = ((int8_t) * (ptr + 2)) <= (int8_t)0xBF; + bool byte4_valid = ((int8_t) * (ptr + 3)) <= (int8_t)0xBF; + if (byte2_valid && byte3_valid && byte4_valid && + // F0, 90..BF, 80..BF, 80..BF + ((byte == 0xF0 && byte2 >= 0x90) || + // F1..F3, 80..BF, 80..BF, 80..BF + (byte >= 0xF1 && byte <= 0xF3) || + // F4, 80..8F, 80..BF, 80..BF + (byte == 0xF4 && byte2 <= 0x8F))) { + ptr += 4; + } else { + return 0; + } + } + // Otherwise, invalid. + else { + return 0; + } + } + // If we got this far, we're valid. + return 1; +} + +static uint8_t const first_len_lookup[16] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 2, 3, +}; + +static uint8_t const first_range_lookup[16] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 8, 8, +}; + +static uint8_t const range_min_lookup[16] = { + 0x00, 0x80, 0x80, 0x80, 0xA0, 0x80, 0x90, 0x80, + 0xC2, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, +}; + +static uint8_t const range_max_lookup[16] = { + 0x7F, 0xBF, 0xBF, 0xBF, 0xBF, 0x9F, 0xBF, 0x8F, + 0xF4, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, +}; + +static uint8_t const range_adjust_lookup[32] = { + 2, 3, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 0, 0, +}; + +static bool is_ascii(uint8x16_t const *const inputs, + uint8x16_t const prev_first_len) { + // Check if we have ASCII, and also that we don't have to treat the prior + // block as special. + // First, verify that we didn't see any non-ASCII bytes in the first half of + // the stride. + uint8x16_t const first_half_clean = vorrq_u8(inputs[0], inputs[1]); + // Then we do the same for the second half of the stride. + uint8x16_t const second_half_clean = vorrq_u8(inputs[2], inputs[3]); + // Check cleanliness of the entire stride. + uint8x16_t const stride_clean = vorrq_u8(first_half_clean, second_half_clean); + // Leave only the high-order set bits. + uint8x16_t const masked = vandq_u8(stride_clean, vdupq_n_u8(0x80)); + // Finally, check that we didn't have any leftover marker bytes in the + // previous block: these are indicated by non-zeroes in prev_first_len. In + // order to trigger a failure, we have to have non-zeroes set in the high bit + // of the lane: we do this by doing a greater-than comparison with a block of + // zeroes. + uint8x16_t const no_prior_dirt = vcgtq_u8(prev_first_len, vdupq_n_u8(0x00)); + // Check for all-zero. + uint64x2_t const result = + vreinterpretq_u64_u8(vorrq_u8(masked, no_prior_dirt)); + return !(vgetq_lane_u64(result, 0) || vgetq_lane_u64(result, 1)); +} + +static void +check_block_neon(uint8x16_t const prev_input, uint8x16_t const prev_first_len, + uint8x16_t *errors, uint8x16_t const first_range_tbl, + uint8x16_t const range_min_tbl, uint8x16_t const range_max_tbl, + uint8x16x2_t const range_adjust_tbl, uint8x16_t const all_ones, + uint8x16_t const all_twos, uint8x16_t const all_e0s, + uint8x16_t const input, uint8x16_t const first_len) { + // Get the high 4-bits of the input. + uint8x16_t const high_nibbles = vshrq_n_u8(input, 4); + // Set range index to 8 for bytes in [C0, FF] by lookup (first byte). + uint8x16_t range = vqtbl1q_u8(first_range_tbl, high_nibbles); + // Reduce the range index based on first_len (second byte). + // This is 0 for [00, 7F], 1 for [C0, DF], 2 for [E0, EF], 3 for [F0, FF]. + range = vorrq_u8(range, vextq_u8(prev_first_len, first_len, 15)); + uint8x16_t tmp[2]; + // Set range index to the saturation of (first_len - 1) (third byte). + // This is 0 for [00, 7F], 0 for [C0, DF], 1 for [E0, EF], 2 for [F0, FF]. + tmp[0] = vextq_u8(prev_first_len, first_len, 14); + tmp[0] = vqsubq_u8(tmp[0], all_ones); + range = vorrq_u8(range, tmp[0]); + // Set range index to the saturation of (first_len - 2) (fourth byte). + // This is 0 for [00, 7F], 0 for [C0, DF], 0 for [E0, EF] and 1 for [F0, FF]. + // This is 'split apart' for speed, as we're not as register-starved as on + // x86. + tmp[1] = vextq_u8(prev_first_len, first_len, 13); + tmp[1] = vqsubq_u8(tmp[1], all_twos); + range = vorrq_u8(range, tmp[1]); + // At this stage, we have calculated range indices correctly, except for + // special cases for first bytes (E0, ED, F0, F4). We repair this to avoid + // missing in the range table. + uint8x16_t const shift1 = vextq_u8(prev_input, input, 15); + uint8x16_t const pos = vsubq_u8(shift1, all_e0s); + range = vaddq_u8(range, vqtbl2q_u8(range_adjust_tbl, pos)); + // We can now load minimum and maximum values from our tables based on the + // calculated indices. + uint8x16_t const minv = vqtbl1q_u8(range_min_tbl, range); + uint8x16_t const maxv = vqtbl1q_u8(range_max_tbl, range); + // Accumulate errors, if any. + errors[0] = vorrq_u8(errors[0], vcltq_u8(input, minv)); + errors[1] = vorrq_u8(errors[1], vcgtq_u8(input, maxv)); +} + +int bytestring_is_valid_utf8(uint8_t const *const src, size_t const len) { + if (len == 0) { + return 1; + } + // We step 64 bytes at a time. + size_t const big_strides = len / 64; + size_t const remaining = len % 64; + uint8_t const *ptr = (uint8_t const *)src; + // Tracking state + uint8x16_t prev_input = vdupq_n_u8(0); + uint8x16_t prev_first_len = vdupq_n_u8(0); + uint8x16_t errors[2] = { + vdupq_n_u8(0), + vdupq_n_u8(0), + }; + // Load our lookup tables. + uint8x16_t const first_len_tbl = vld1q_u8(first_len_lookup); + uint8x16_t const first_range_tbl = vld1q_u8(first_range_lookup); + uint8x16_t const range_min_tbl = vld1q_u8(range_min_lookup); + uint8x16_t const range_max_tbl = vld1q_u8(range_max_lookup); + uint8x16x2_t const range_adjust_tbl = vld2q_u8(range_adjust_lookup); + // Useful constants. + uint8x16_t const all_ones = vdupq_n_u8(1); + uint8x16_t const all_twos = vdupq_n_u8(2); + uint8x16_t const all_e0s = vdupq_n_u8(0xE0); + for (size_t i = 0; i < big_strides; i++) { + // Load 64 bytes + uint8x16_t const inputs[4] = {vld1q_u8(ptr), vld1q_u8(ptr + 16), + vld1q_u8(ptr + 32), vld1q_u8(ptr + 48)}; + // Check if we have ASCII + if (is_ascii(inputs, prev_first_len)) { + // Prev_first_len cheaply. + prev_first_len = vqtbl1q_u8(first_len_tbl, vshrq_n_u8(inputs[3], 4)); + } else { + uint8x16_t first_len = + vqtbl1q_u8(first_len_tbl, vshrq_n_u8(inputs[0], 4)); + check_block_neon(prev_input, prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, range_adjust_tbl, all_ones, + all_twos, all_e0s, inputs[0], first_len); + prev_first_len = first_len; + first_len = vqtbl1q_u8(first_len_tbl, vshrq_n_u8(inputs[1], 4)); + check_block_neon(inputs[0], prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, range_adjust_tbl, all_ones, + all_twos, all_e0s, inputs[1], first_len); + prev_first_len = first_len; + first_len = vqtbl1q_u8(first_len_tbl, vshrq_n_u8(inputs[2], 4)); + check_block_neon(inputs[1], prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, range_adjust_tbl, all_ones, + all_twos, all_e0s, inputs[2], first_len); + prev_first_len = first_len; + first_len = vqtbl1q_u8(first_len_tbl, vshrq_n_u8(inputs[3], 4)); + check_block_neon(inputs[2], prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, range_adjust_tbl, all_ones, + all_twos, all_e0s, inputs[3], first_len); + prev_first_len = first_len; + } + // Set prev_input based on last block. + prev_input = inputs[3]; + // Advance. + ptr += 64; + } + // Combine error carriers with a manually-unrolled loop, then check if + // anything went awry. + if (vmaxvq_u8(vorrq_u8(errors[0], errors[1])) != 0) { + return 0; + } + //'Roll back' our pointer a little to prepare for a slow search of the rest. + uint32_t token; + vst1q_lane_u32(&token, vreinterpretq_u32_u8(prev_input), 3); + uint8_t const *token_ptr = (uint8_t const *)&token; + ptrdiff_t rollback = 0; + // We must not roll back if no big blocks were processed, as then + // the fallback function would examine out-of-bounds data (#620). + // In that case, prev_input contains only nulls and we skip the if body. + if (token_ptr[3] >= 0x80u) { + // Look for an incomplete multi-byte code point + if (token_ptr[3] >= 0xC0u) { + rollback = 1; + } else if (token_ptr[2] >= 0xE0u) { + rollback = 2; + } else if (token_ptr[1] >= 0xF0u) { + rollback = 3; + } + } + // Finish the job. + uint8_t const *const small_ptr = ptr - rollback; + size_t const small_len = remaining + rollback; + return is_valid_utf8_fallback(small_ptr, small_len); +} + +#pragma GCC pop_options diff --git a/cbits/aligned-static-hs-data.c b/cbits/aligned-static-hs-data.c new file mode 100644 --- /dev/null +++ b/cbits/aligned-static-hs-data.c @@ -0,0 +1,756 @@ +// This file contains various chunks of raw static data that we can't +// put into GHC-Haskell primitive string literals because we perform +// /aligned/ reads with them. + +#include "MachDeps.h" +#include + +extern const char hs_bytestring_lower_hex_table[513]; +const char hs_bytestring_lower_hex_table[513] + __attribute__(( aligned(ALIGNMENT_WORD16) )) + = "000102030405060708090a0b0c0d0e0f" + "101112131415161718191a1b1c1d1e1f" + "202122232425262728292a2b2c2d2e2f" + "303132333435363738393a3b3c3d3e3f" + "404142434445464748494a4b4c4d4e4f" + "505152535455565758595a5b5c5d5e5f" + "606162636465666768696a6b6c6d6e6f" + "707172737475767778797a7b7c7d7e7f" + "808182838485868788898a8b8c8d8e8f" + "909192939495969798999a9b9c9d9e9f" + "a0a1a2a3a4a5a6a7a8a9aaabacadaeaf" + "b0b1b2b3b4b5b6b7b8b9babbbcbdbebf" + "c0c1c2c3c4c5c6c7c8c9cacbcccdcecf" + "d0d1d2d3d4d5d6d7d8d9dadbdcdddedf" + "e0e1e2e3e4e5e6e7e8e9eaebecedeeef" + "f0f1f2f3f4f5f6f7f8f9fafbfcfdfeff"; + +extern const char hs_bytestring_digit_pairs_table[201]; +const char hs_bytestring_digit_pairs_table[201] + __attribute__(( aligned(ALIGNMENT_WORD16) )) + = "00010203040506070809" + "10111213141516171819" + "20212223242526272829" + "30313233343536373839" + "40414243444546474849" + "50515253545556575859" + "60616263646566676869" + "70717273747576777879" + "80818283848586878889" + "90919293949596979899"; + +extern const uint64_t hs_bytestring_float_pow5_inv_split[31]; +const uint64_t hs_bytestring_float_pow5_inv_split[31] = { +// map (finv float_pow5_inv_bitcount) [0..float_max_inv_split] + 0x800000000000001, + 0x666666666666667, + 0x51eb851eb851eb9, + 0x4189374bc6a7efa, + 0x68db8bac710cb2a, + 0x53e2d6238da3c22, + 0x431bde82d7b634e, + 0x6b5fca6af2bd216, + 0x55e63b88c230e78, + 0x44b82fa09b5a52d, + 0x6df37f675ef6eae, + 0x57f5ff85e592558, + 0x465e6604b7a8447, + 0x709709a125da071, + 0x5a126e1a84ae6c1, + 0x480ebe7b9d58567, + 0x734aca5f6226f0b, + 0x5c3bd5191b525a3, + 0x49c97747490eae9, + 0x760f253edb4ab0e, + 0x5e72843249088d8, + 0x4b8ed0283a6d3e0, + 0x78e480405d7b966, + 0x60b6cd004ac9452, + 0x4d5f0a66a23a9db, + 0x7bcb43d769f762b, + 0x63090312bb2c4ef, + 0x4f3a68dbc8f03f3, + 0x7ec3daf94180651, + 0x65697bfa9acd1da, + 0x51212ffbaf0a7e2 +}; + +extern const uint64_t hs_bytestring_float_pow5_split[47]; +const uint64_t hs_bytestring_float_pow5_split[47] = { +// map (fnorm float_pow5_bitcount) [0..float_max_split] + 0x1000000000000000, + 0x1400000000000000, + 0x1900000000000000, + 0x1f40000000000000, + 0x1388000000000000, + 0x186a000000000000, + 0x1e84800000000000, + 0x1312d00000000000, + 0x17d7840000000000, + 0x1dcd650000000000, + 0x12a05f2000000000, + 0x174876e800000000, + 0x1d1a94a200000000, + 0x12309ce540000000, + 0x16bcc41e90000000, + 0x1c6bf52634000000, + 0x11c37937e0800000, + 0x16345785d8a00000, + 0x1bc16d674ec80000, + 0x1158e460913d0000, + 0x15af1d78b58c4000, + 0x1b1ae4d6e2ef5000, + 0x10f0cf064dd59200, + 0x152d02c7e14af680, + 0x1a784379d99db420, + 0x108b2a2c28029094, + 0x14adf4b7320334b9, + 0x19d971e4fe8401e7, + 0x1027e72f1f128130, + 0x1431e0fae6d7217c, + 0x193e5939a08ce9db, + 0x1f8def8808b02452, + 0x13b8b5b5056e16b3, + 0x18a6e32246c99c60, + 0x1ed09bead87c0378, + 0x13426172c74d822b, + 0x1812f9cf7920e2b6, + 0x1e17b84357691b64, + 0x12ced32a16a1b11e, + 0x178287f49c4a1d66, + 0x1d6329f1c35ca4bf, + 0x125dfa371a19e6f7, + 0x16f578c4e0a060b5, + 0x1cb2d6f618c878e3, + 0x11efc659cf7d4b8d, + 0x166bb7f0435c9e71, + 0x1c06a5ec5433c60d +}; + +extern const uint64_t hs_bytestring_double_pow5_inv_split[584]; +const uint64_t hs_bytestring_double_pow5_inv_split[584] = { +// splitWord128s $ map (finv double_pow5_inv_bitcount) [0..double_max_inv_split] + 0x1,0x2000000000000000, + 0x999999999999999a,0x1999999999999999, + 0x47ae147ae147ae15,0x147ae147ae147ae1, + 0x6c8b4395810624de,0x10624dd2f1a9fbe7, + 0x7a786c226809d496,0x1a36e2eb1c432ca5, + 0x61f9f01b866e43ab,0x14f8b588e368f084, + 0xb4c7f34938583622,0x10c6f7a0b5ed8d36, + 0x87a6520ec08d236a,0x1ad7f29abcaf4857, + 0x9fb841a566d74f88,0x15798ee2308c39df, + 0xe62d01511f12a607,0x112e0be826d694b2, + 0xd6ae6881cb5109a4,0x1b7cdfd9d7bdbab7, + 0xdef1ed34a2a73aea,0x15fd7fe17964955f, + 0x7f27f0f6e885c8bb,0x119799812dea1119, + 0x650cb4be40d60df8,0x1c25c268497681c2, + 0xea70909833de7193,0x16849b86a12b9b01, + 0x21f3a6e0297ec143,0x1203af9ee756159b, + 0x6985d7cd0f313537,0x1cd2b297d889bc2b, + 0x2137dfd73f5a90f9,0x170ef54646d49689, + 0xe75fe645cc4873fa,0x12725dd1d243aba0, + 0xa5663d3c7a0d865d,0x1d83c94fb6d2ac34, + 0x511e976394d79eb1,0x179ca10c9242235d, + 0xda7edf82dd794bc1,0x12e3b40a0e9b4f7d, + 0x2a6498d1625bac68,0x1e392010175ee596, + 0xeeb6e0a781e2f053,0x182db34012b25144, + 0x58924d52ce4f26a9,0x1357c299a88ea76a, + 0x27507bb7b07ea441,0x1ef2d0f5da7dd8aa, + 0x52a6c95fc0655034,0x18c240c4aecb13bb, + 0xeebd44c99eaa690,0x13ce9a36f23c0fc9, + 0xb17953adc3110a80,0x1fb0f6be50601941, + 0xc12ddc8b02740867,0x195a5efea6b34767, + 0x3424b06f3529a052,0x14484bfeebc29f86, + 0x901d59f290ee19db,0x1039d66589687f9e, + 0x4cfbc31db4b0295f,0x19f623d5a8a73297, + 0x3d9635b15d59bab2,0x14c4e977ba1f5bac, + 0x97ab5e277de16228,0x109d8792fb4c4956, + 0xf2abc9d8c9689d0d,0x1a95a5b7f87a0ef0, + 0x5bbca17a3aba173e,0x154484932d2e725a, + 0xafca1ac82efb45cb,0x11039d428a8b8eae, + 0xb2dcf7a6b1920945,0x1b38fb9daa78e44a, + 0xf57d92ebc141a104,0x15c72fb1552d836e, + 0xc46475896767b403,0x116c262777579c58, + 0x6d6d88dbd8a5ecd2,0x1be03d0bf225c6f4, + 0x8abe071646eb23db,0x164cfda3281e38c3, + 0x6efe6c11d255b649,0x11d7314f534b609c, + 0xb197134fb6ef8a0e,0x1c8b821885456760, + 0x27ac0f72f8bfa1a5,0x16d601ad376ab91a, + 0xb95672c260994e1e,0x1244ce242c5560e1, + 0xf5571e03cdc21695,0x1d3ae36d13bbce35, + 0x2aac18030b01abab,0x17624f8a762fd82b, + 0xbbbce0026f348956,0x12b50c6ec4f31355, + 0x92c7ccd0b1eda889,0x1dee7a4ad4b81eef, + 0xdbd30a408e57ba07,0x17f1fb6f10934bf2, + 0x7ca8d50071dfc806,0x1327fc58da0f6ff5, + 0xfaa7bb33e9660cd6,0x1ea6608e29b24cbb, + 0x9552fc298784d711,0x18851a0b548ea3c9, + 0xaaa8c9bad2d0ac0e,0x139dae6f76d88307, + 0xdddadc5e1e1aace3,0x1f62b0b257c0d1a5, + 0x7e48b04b4b488a4f,0x191bc08eac9a4151, + 0xcb6d59d5d5d3a1d9,0x141633a556e1cdda, + 0x3c577b1177dc817b,0x1011c2eaabe7d7e2, + 0xc6f25e825960cf2a,0x19b604aaaca62636, + 0x6bf518684780a5bb,0x14919d5556eb51c5, + 0x232a79ed06008496,0x10747ddddf22a7d1, + 0xd1dd8fe1a3340756,0x1a53fc9631d10c81, + 0xa7e4731ae8f66c45,0x150ffd44f4a73d34, + 0x531d28e253f8569e,0x10d9976a5d52975d, + 0xeb61db03b98d5762,0x1af5bf109550f22e, + 0xbc4e48cfc7a445e8,0x159165a6ddda5b58, + 0x6371d3d96c836b20,0x11411e1f17e1e2ad, + 0x9f1c8628ad9f11cd,0x1b9b6364f3030448, + 0xe5b06b53be18db0b,0x1615e91d8f359d06, + 0xeaf3890fcb4715a2,0x11ab20e472914a6b, + 0x44b8db4c7871bc37,0x1c45016d841baa46, + 0x3c715d6c6c1635f,0x169d9abe03495505, + 0x3638de456bcde919,0x1217aefe69077737, + 0x56c163a2461641c1,0x1cf2b1970e725858, + 0xdf011c81d1ab67ce,0x17288e1271f51379, + 0x7f3416ce4155eca5,0x1286d80ec190dc61, + 0x6520247d3556476e,0x1da48ce468e7c702, + 0xea801d30f7783925,0x17b6d71d20b96c01, + 0xbb99b0f3f92cfa84,0x12f8ac174d612334, + 0x5f5c4e532847f739,0x1e5aacf215683854, + 0x7f7d0b75b9d32c2e,0x18488a5b44536043, + 0x9930d5f7c7dc2358,0x136d3b7c36a919cf, + 0x8eb4898c72f9d226,0x1f152bf9f10e8fb2, + 0x722a07a38f2e41b8,0x18ddbcc7f40ba628, + 0xc1bb394fa5be9afa,0x13e497065cd61e86, + 0x9c5ec2190930f7f6,0x1fd424d6faf030d7, + 0x49e56814075a5ff8,0x197683df2f268d79, + 0x6e51201005e1e660,0x145ecfe5bf520ac7, + 0xf1da800cd181851a,0x104bd984990e6f05, + 0x4fc400148268d4f5,0x1a12f5a0f4e3e4d6, + 0xd96999aa01ed772b,0x14dbf7b3f71cb711, + 0xadee1488018ac5bc,0x10aff95cc5b09274, + 0x497ceda668de092c,0x1ab328946f80ea54, + 0x3aca57b853e4d424,0x155c2076bf9a5510, + 0x623b7960431d7683,0x1116805effaeaa73, + 0x9d2bf566d1c8bd9e,0x1b5733cb32b110b8, + 0x7dbcc452416d647f,0x15df5ca28ef40d60, + 0xcafd69db678ab6cc,0x117f7d4ed8c33de6, + 0xab2f0fc572778adf,0x1bff2ee48e052fd7, + 0x88f273045b92d580,0x1665bf1d3e6a8cac, + 0xd3f528d049424466,0x11eaff4a98553d56, + 0xb988414d4203a0a3,0x1cab3210f3bb9557, + 0x6139cdd76802e6e9,0x16ef5b40c2fc7779, + 0xe761717920025254,0x125915cd68c9f92d, + 0xa568b58e999d5086,0x1d5b561574765b7c, + 0x5120913ee14aa6d2,0x177c44ddf6c515fd, + 0xa74d40ff1aa21f0e,0x12c9d0b1923744ca, + 0xbaece64f769cb4a,0x1e0fb44f50586e11, + 0x3c8bd850c5ee3c3b,0x180c903f7379f1a7, + 0xca0979da37f1c9c9,0x133d4032c2c7f485, + 0xa9a8c2f6bfe942db,0x1ec866b79e0cba6f, + 0x2153cf2bccba9be3,0x18a0522c7e709526, + 0x1aa9728970954982,0x13b374f06526ddb8, + 0xf775840f1a88759d,0x1f8587e7083e2f8c, + 0x5f9136727ba05e17,0x19379fec0698260a, + 0x1940f85b9619e4df,0x142c7ff0054684d5, + 0xe100c6afab47ea4c,0x1023998cd1053710, + 0xce67a44c453fdd47,0x19d28f47b4d524e7, + 0xd852e9d69dccb106,0x14a8729fc3ddb71f, + 0x79dbee454b0a2738,0x1086c219697e2c19, + 0x295fe3a211a9d859,0x1a71368f0f30468f, + 0xbab31c81a7bb137a,0x15275ed8d8f36ba5, + 0x6228e39aec95a92f,0x10ec4be0ad8f8951, + 0x9d0e38f7e0ef7517,0x1b13ac9aaf4c0ee8, + 0xb0d82d931a592a79,0x15a956e225d67253, + 0x8d79be0f4847552e,0x11544581b7dec1dc, + 0x158f967eda0bbb7c,0x1bba08cf8c979c94, + 0x77a611ff14d62f97,0x162e6d72d6dfb076, + 0xf951a7ff43de8c79,0x11bebdf578b2f391, + 0xc21c3ffed2fdad8e,0x1c6463225ab7ec1c, + 0x1b0333242648ad8,0x16b6b5b5155ff017, + 0x159c28e9b83a246,0x122bc490dde659ac, + 0xcef604175f3903a3,0x1d12d41afca3c2ac, + 0x725e69ac4c2d9c83,0x17424348ca1c9bbd, + 0xf5185489d68ae39c,0x129b69070816e2fd, + 0xee8d540fbdab05c6,0x1dc574d80cf16b2f, + 0xbed77672fe226b05,0x17d12a4670c1228c, + 0xff12c528cb4ebc04,0x130dbb6b8d674ed6, + 0xcb513b74787df9a0,0x1e7c5f127bd87e24, + 0x90dc929f9fe614d,0x18637f41fcad31b7, + 0xa0d7d42194cb810a,0x1382cc34ca2427c5, + 0x67bfb9cf5478ce77,0x1f37ad21436d0c6f, + 0x1fcc94a5dd2d71f9,0x18f9574dcf8a7059, + 0x7fd6dd517dbdf4c7,0x13faac3e3fa1f37a, + 0xffbe2ee8c92fee0b,0x1ff779fd329cb8c3, + 0x6631bf20a0f324d6,0x1992c7fdc216fa36, + 0xb827cc1a1a5c1d78,0x14756ccb01abfb5e, + 0x935309ae7b7ce460,0x105df0a267bcc918, + 0x1eeb42b0c594a099,0x1a2fe76a3f9474f4, + 0xe58902270476e6e1,0x14f31f8832dd2a5c, + 0xb7a0ce859d2bebe7,0x10c27fa028b0eeb0, + 0x59014a6f61dfdfd8,0x1ad0cc33744e4ab4, + 0xe0cdd525e7e64cad,0x1573d68f903ea229, + 0x4d7177518651d6f1,0x11297872d9cbb4ee, + 0x7be8bee8d6e957e8,0x1b758d848fac54b0, + 0xfcba3253df211320,0x15f7a46a0c89dd59, + 0x63c8284318e74280,0x1192e9ee706e4aae, + 0x60d0d3827d86a66,0x1c1e43171a4a1117, + 0x6b3da42cecad21eb,0x167e9c127b6e7412, + 0x88fe1cf0bd574e56,0x11fee341fc585cdb, + 0x419694b462254a23,0x1ccb0536608d615f, + 0x67abaa29e81dd4e9,0x1708d0f84d3de77f, + 0xb95621bb2017dd87,0x126d73f9d764b932, + 0xc223692b668c95a5,0x1d7becc2f23ac1ea, + 0xce82ba891ed6de1d,0x179657025b6234bb, + 0xa53562074bdf1818,0x12deac01e2b4f6fc, + 0x3b889cd87964f359,0x1e3113363787f194, + 0xfc6d4a46c783f5e1,0x18274291c6065adc, + 0x30576e9f06032b1a,0x13529ba7d19eaf17, + 0x1a257dcb3cd1de90,0x1eea92a61c311825, + 0x481dfe3c30a7e540,0x18bba884e35a79b7, + 0xd34b31c9c0865100,0x13c9539d82aec7c5, + 0x5211e942cda3b4cd,0x1fa885c8d117a609, + 0x74db21023e1c90a4,0x19539e3a40dfb807, + 0xf715b401cb4a0d50,0x1442e4fb67196005, + 0xf8de299b09080aa7,0x103583fc527ab337, + 0x8e304291a80cddd7,0x19ef3993b72ab859, + 0x3e8d020e200a4b13,0x14bf6142f8eef9e1, + 0x653d9b3e80083c0f,0x10991a9bfa58c7e7, + 0x6ec8f864000d2ce4,0x1a8e90f9908e0ca5, + 0x8bd3f9e999a423ea,0x153eda614071a3b7, + 0x3ca994bae1501cbb,0x10ff151a99f482f9, + 0xc775bac49bb3612b,0x1b31bb5dc320d18e, + 0xd2c4956a16291a89,0x15c162b168e70e0b, + 0xdbd0778811ba7ba1,0x11678227871f3e6f, + 0x2c80bf401c5d929b,0x1bd8d03f3e9863e6, + 0xbd33cc3349e47549,0x16470cff6546b651, + 0xca8fd68f6e505dd4,0x11d270cc51055ea7, + 0x4419574be3b3c953,0x1c83e7ad4e6efdd9, + 0x347790982f63aa9,0x16cfec8aa52597e1, + 0xcf6c60d468c4fbba,0x123ff06eea847980, + 0xe57a34870e07f92a,0x1d331a4b10d3f59a, + 0x512e906c0b399422,0x175c1508da432ae2, + 0xda8ba6bcd5c7a9b5,0x12b010d3e1cf5581, + 0x90df712e22d90f87,0x1de6815302e5559c, + 0xda4c5a8b4f140c6c,0x17eb9aa8cf1dde16, + 0xaea37ba2a5a9a38a,0x1322e220a5b17e78, + 0x7dd25f6aa2a905a9,0x1e9e369aa2b59727, + 0x97db7f888220d154,0x187e92154ef7ac1f, + 0x797c6606ce80a777,0x139874ddd8c6234c, + 0x8f2d700ae4010bf1,0x1f5a549627a36bad, + 0xc2459a25000d65a,0x191510781fb5efbe, + 0x701d1481d99a4515,0x1410d9f9b2f7f2fe, + 0xc017439b147b6a77,0x100d7b2e28c65bfe, + 0xccf205c4ed9243f2,0x19af2b7d0e0a2cca, + 0xa5b37d0be0e9cc2,0x148c22ca71a1bd6f, + 0x848f973cb3ee3ce,0x10701bd527b4978c, + 0xda0e5bec78649fb0,0x1a4cf9550c5425ac, + 0x7b3eaff060507fc0,0x150a6110d6a9b7bd, + 0x95cbbff380406633,0x10d51a73deee2c97, + 0xefac665266cd7052,0x1aee90b964b04758, + 0x2623850eb8a459db,0x158ba6fab6f36c47, + 0x1e82d0d893b6ae49,0x113c85955f29236c, + 0xfd9e1af41f8ab075,0x1b9408eefea838ac, + 0x97b1af29b2d559f7,0x16100725988693bd, + 0xac8e25baf5777b2c,0x11a66c1e139edc97, + 0x7a7d092b2258c513,0x1c3d79c9b8fe2dbf, + 0x61fda0ef4ead6a76,0x169794a160cb57cc, + 0xe7fe1a590bbdeec5,0x1212dd4de7091309, + 0xa6635d5b45fcb13a,0x1ceafbafd80e84dc, + 0x851c4aaf6b308dc8,0x172262f3133ed0b0, + 0xd0e36ef2bc26d7d4,0x1281e8c275cbda26, + 0xb49f17eac6a48c86,0x1d9ca79d894629d7, + 0x2a18dfef0550706b,0x17b08617a104ee46, + 0x54e0b3259dd9f389,0x12f39e794d9d8b6b, + 0x87cdeb6f62f65274,0x1e5297287c2f4578, + 0xd30b22bf825ea85d,0x18421286c9bf6ac6, + 0xf3c1bcc684bb9e4,0x13680ed23aff889f, + 0x18602c7a4079296d,0x1f0ce4839198da98, + 0x46b356c833942124,0x18d71d360e13e213, + 0x388f78a029434db6,0x13df4a91a4dcb4dc, + 0x5a7f2766a86baf8a,0x1fcbaa82a1612160, + 0x153285ebb9efbfa2,0x196fbb9bb44db44d, + 0xaa8ed189618c994e,0x145962e2f6a4903d, + 0xeed8a7a11ad6e10c,0x1047824f2bb6d9ca, + 0x7e27729b5e249b45,0x1a0c03b1df8af611, + 0xfe85f549181d4904,0x14d6695b193bf80d, + 0xcb9e5dd4134aa0d0,0x10ab877c142ff9a4, + 0xdf63c9535211014d,0x1aac0bf9b9e65c3a, + 0x191ca10f74da6771,0x15566ffafb1eb02f, + 0xadb080d92a4852c1,0x1111f32f2f4bc025, + 0x15e7348eaa0d5134,0x1b4feb7eb212cd09, + 0xab1f5d3eee710dc4,0x15d98932280f0a6d, + 0xbc1917658b8da49d,0x117ad428200c0857, + 0x2cf4f23c127c3a94,0x1bf7b9d9cce00d59, + 0xf0c3f4fcdb969543,0x165fc7e170b33de0, + 0x5a365d9716121103,0x11e6398126f5cb1a, + 0x9056fc24f01ce804,0x1ca38f350b22de90, + 0xd9df301d8ce3ecd0,0x16e93f5da2824ba6, + 0xe17f59b13d8323da,0x125432b14ecea2eb, + 0x68cbc2b52f38395c,0x1d53844ee47dd179, + 0x53d6355dbf602de3,0x177603725064a794, + 0xa9782ab165e68b1c,0x12c4cf8ea6b6ec76, + 0xf26aab56fd744fa,0x1e07b27dd78b13f1, + 0x3f52222abfdf6a62,0x18062864ac6f4327, + 0x65db4e88997f884e,0x1338205089f29c1f, + 0x6fc54a7428cc0d4a,0x1ec033b40fea9365, + 0x596aa1f68709a43b,0x1899c2f673220f84, + 0xadeee7f86c07b696,0x13ae3591f5b4d936, + 0x497e3ff3e00c5756,0x1f7d228322baf524, + 0xd464fff64cd6ac45,0x1930e868e89590e9, + 0x4383fff83d7889d1,0x14272053ed4473ee, + 0xcf9cccc69793a174,0x101f4d0ff1038ff1, + 0x7f6147a425b90252,0x19cbae7fe805b31c, + 0xcc4dd2e9b7c7350f,0x14a2f1ffecd15c16, + 0x3d0b0f215fd290d9,0x10825b3323dab012, + 0x61ab4b689950e7c1,0x1a6a2b85062ab350, + 0x4e22a2ba1440b967,0x1521bc6a6b555c40, + 0xb4ee894dd009453,0x10e7c9eebc4449cd, + 0x1217da87c800ed51,0x1b0c764ac6d3a948, + 0xdb46486ca000bdda,0x15a391d56bdc876c, + 0x490506bd4ccd64af,0x114fa7ddefe39f8a, + 0xa8080ac87ae23ab1,0x1bb2a62fe638ff43, + 0x5339a239fbe82ef4,0x162884f31e93ff69, + 0x75c7b4fb2fecf25d,0x11ba03f5b20fff87, + 0x22d92191e647ea2e,0x1c5cd322b67fff3f, + 0xb57a8141850654f2,0x16b0a8e891ffff65, + 0xc4620101373843f5,0x1226ed86db3332b7, + 0x3a366801f1f39fee,0x1d0b15a491eb8459, + 0xfb5eb99b27f6198b,0x173c115074bc69e0, + 0x2f7efae2865e7ad6,0x129674405d6387e7, + 0xe597f7d0d6fd9156,0x1dbd86cd6238d971, + 0x8479930d78cadaab,0x17cad23de82d7ac1, + 0xd06142712d6f1556,0x1308a831868ac89a, + 0x4d686a4eaf182222,0x1e74404f3daada91, + 0xa453883ef279b4e8,0x185d003f6488aeda, + 0xe9dc6cff28615d87,0x137d99cc506d58ae, + 0xa960ae650d6895a4,0x1f2f5c7a1a488de4, + 0xbab3beb73ded4483,0x18f2b061aea07183, + 0x2ef6322c318a9d36,0x13f559e7bee6c136 +}; + +extern const uint64_t hs_bytestring_double_pow5_split[652]; +const uint64_t hs_bytestring_double_pow5_split[652] = { +// splitWord128s $ map (fnorm double_pow5_bitcount) [0..double_max_split] + 0x0,0x1000000000000000, + 0x0,0x1400000000000000, + 0x0,0x1900000000000000, + 0x0,0x1f40000000000000, + 0x0,0x1388000000000000, + 0x0,0x186a000000000000, + 0x0,0x1e84800000000000, + 0x0,0x1312d00000000000, + 0x0,0x17d7840000000000, + 0x0,0x1dcd650000000000, + 0x0,0x12a05f2000000000, + 0x0,0x174876e800000000, + 0x0,0x1d1a94a200000000, + 0x0,0x12309ce540000000, + 0x0,0x16bcc41e90000000, + 0x0,0x1c6bf52634000000, + 0x0,0x11c37937e0800000, + 0x0,0x16345785d8a00000, + 0x0,0x1bc16d674ec80000, + 0x0,0x1158e460913d0000, + 0x0,0x15af1d78b58c4000, + 0x0,0x1b1ae4d6e2ef5000, + 0x0,0x10f0cf064dd59200, + 0x0,0x152d02c7e14af680, + 0x0,0x1a784379d99db420, + 0x0,0x108b2a2c28029094, + 0x0,0x14adf4b7320334b9, + 0x4000000000000000,0x19d971e4fe8401e7, + 0x8800000000000000,0x1027e72f1f128130, + 0xaa00000000000000,0x1431e0fae6d7217c, + 0xd480000000000000,0x193e5939a08ce9db, + 0xc9a0000000000000,0x1f8def8808b02452, + 0xbe04000000000000,0x13b8b5b5056e16b3, + 0xad85000000000000,0x18a6e32246c99c60, + 0xd8e6400000000000,0x1ed09bead87c0378, + 0x878fe80000000000,0x13426172c74d822b, + 0x6973e20000000000,0x1812f9cf7920e2b6, + 0x3d0da8000000000,0x1e17b84357691b64, + 0x8262889000000000,0x12ced32a16a1b11e, + 0x22fb2ab400000000,0x178287f49c4a1d66, + 0xabb9f56100000000,0x1d6329f1c35ca4bf, + 0xcb54395ca0000000,0x125dfa371a19e6f7, + 0xbe2947b3c8000000,0x16f578c4e0a060b5, + 0x2db399a0ba000000,0x1cb2d6f618c878e3, + 0xfc90400474400000,0x11efc659cf7d4b8d, + 0x7bb4500591500000,0x166bb7f0435c9e71, + 0xdaa16406f5a40000,0x1c06a5ec5433c60d, + 0xa8a4de8459868000,0x118427b3b4a05bc8, + 0xd2ce16256fe82000,0x15e531a0a1c872ba, + 0x87819baecbe22800,0x1b5e7e08ca3a8f69, + 0xf4b1014d3f6d5900,0x111b0ec57e6499a1, + 0x71dd41a08f48af40,0x1561d276ddfdc00a, + 0xe549208b31adb10,0x1aba4714957d300d, + 0x28f4db456ff0c8ea,0x10b46c6cdd6e3e08, + 0x33321216cbecfb24,0x14e1878814c9cd8a, + 0xbffe969c7ee839ed,0x1a19e96a19fc40ec, + 0xf7ff1e21cf512434,0x105031e2503da893, + 0xf5fee5aa43256d41,0x14643e5ae44d12b8, + 0x337e9f14d3eec892,0x197d4df19d605767, + 0x5e46da08ea7ab6,0x1fdca16e04b86d41, + 0xa03aec4845928cb2,0x13e9e4e4c2f34448, + 0xc849a75a56f72fde,0x18e45e1df3b0155a, + 0x7a5c1130ecb4fbd6,0x1f1d75a5709c1ab1, + 0xec798abe93f11d65,0x13726987666190ae, + 0xa797ed6e38ed64bf,0x184f03e93ff9f4da, + 0x517de8c9c728bdef,0x1e62c4e38ff87211, + 0xd2eeb17e1c7976b5,0x12fdbb0e39fb474a, + 0x87aa5ddda397d462,0x17bd29d1c87a191d, + 0xe994f5550c7dc97b,0x1dac74463a989f64, + 0x11fd195527ce9ded,0x128bc8abe49f639f, + 0xd67c5faa71c24568,0x172ebad6ddc73c86, + 0x8c1b77950e32d6c2,0x1cfa698c95390ba8, + 0x57912abd28dfc639,0x121c81f7dd43a749, + 0xad75756c7317b7c8,0x16a3a275d494911b, + 0x98d2d2c78fdda5ba,0x1c4c8b1349b9b562, + 0x9f83c3bcb9ea8794,0x11afd6ec0e14115d, + 0x764b4abe8652979,0x161bcca7119915b5, + 0x493de1d6e27e73d7,0x1ba2bfd0d5ff5b22, + 0x6dc6ad264d8f0866,0x1145b7e285bf98f5, + 0xc938586fe0f2ca80,0x159725db272f7f32, + 0x7b866e8bd92f7d20,0x1afcef51f0fb5eff, + 0xad34051767bdae34,0x10de1593369d1b5f, + 0x9881065d41ad19c1,0x15159af804446237, + 0x7ea147f492186032,0x1a5b01b605557ac5, + 0x6f24ccf8db4f3c1f,0x1078e111c3556cbb, + 0x4aee003712230b27,0x14971956342ac7ea, + 0xdda98044d6abcdf0,0x19bcdfabc13579e4, + 0xa89f02b062b60b6,0x10160bcb58c16c2f, + 0xcd2c6c35c7b638e4,0x141b8ebe2ef1c73a, + 0x8077874339a3c71d,0x1922726dbaae3909, + 0xe0956914080cb8e4,0x1f6b0f092959c74b, + 0x6c5d61ac8507f38e,0x13a2e965b9d81c8f, + 0x4774ba17a649f072,0x188ba3bf284e23b3, + 0x1951e89d8fdc6c8f,0x1eae8caef261aca0, + 0xfd3316279e9c3d9,0x132d17ed577d0be4, + 0x13c7fdbb186434cf,0x17f85de8ad5c4edd, + 0x58b9fd29de7d4203,0x1df67562d8b36294, + 0xb7743e3a2b0e4942,0x12ba095dc7701d9c, + 0xe5514dc8b5d1db92,0x17688bb5394c2503, + 0xdea5a13ae3465277,0x1d42aea2879f2e44, + 0xb2784c4ce0bf38a,0x1249ad2594c37ceb, + 0xcdf165f6018ef06d,0x16dc186ef9f45c25, + 0x416dbf7381f2ac88,0x1c931e8ab871732f, + 0x88e497a83137abd5,0x11dbf316b346e7fd, + 0xeb1dbd923d8596ca,0x1652efdc6018a1fc, + 0x25e52cf6cce6fc7d,0x1be7abd3781eca7c, + 0x97af3c1a40105dce,0x1170cb642b133e8d, + 0xfd9b0b20d0147542,0x15ccfe3d35d80e30, + 0x3d01cde904199292,0x1b403dcc834e11bd, + 0x462120b1a28ffb9b,0x1108269fd210cb16, + 0xd7a968de0b33fa82,0x154a3047c694fddb, + 0xcd93c3158e00f923,0x1a9cbc59b83a3d52, + 0xc07c59ed78c09bb6,0x10a1f5b813246653, + 0xb09b7068d6f0c2a3,0x14ca732617ed7fe8, + 0xdcc24c830cacf34c,0x19fd0fef9de8dfe2, + 0xc9f96fd1e7ec180f,0x103e29f5c2b18bed, + 0x3c77cbc661e71e13,0x144db473335deee9, + 0x8b95beb7fa60e598,0x1961219000356aa3, + 0x6e7b2e65f8f91efe,0x1fb969f40042c54c, + 0xc50cfcffbb9bb35f,0x13d3e2388029bb4f, + 0xb6503c3faa82a037,0x18c8dac6a0342a23, + 0xa3e44b4f95234844,0x1efb1178484134ac, + 0xe66eaf11bd360d2b,0x135ceaeb2d28c0eb, + 0xe00a5ad62c839075,0x183425a5f872f126, + 0x980cf18bb7a47493,0x1e412f0f768fad70, + 0x5f0816f752c6c8dc,0x12e8bd69aa19cc66, + 0xf6ca1cb527787b13,0x17a2ecc414a03f7f, + 0xf47ca3e2715699d7,0x1d8ba7f519c84f5f, + 0xf8cde66d86d62026,0x127748f9301d319b, + 0xf7016008e88ba830,0x17151b377c247e02, + 0xb4c1b80b22ae923c,0x1cda62055b2d9d83, + 0x50f91306f5ad1b65,0x12087d4358fc8272, + 0xe53757c8b318623f,0x168a9c942f3ba30e, + 0x9e852dbadfde7acf,0x1c2d43b93b0a8bd2, + 0xa3133c94cbeb0cc1,0x119c4a53c4e69763, + 0x8bd80bb9fee5cff1,0x16035ce8b6203d3c, + 0xaece0ea87e9f43ee,0x1b843422e3a84c8b, + 0x4d40c9294f238a75,0x1132a095ce492fd7, + 0x2090fb73a2ec6d12,0x157f48bb41db7bcd, + 0x68b53a508ba78856,0x1adf1aea12525ac0, + 0x417144725748b536,0x10cb70d24b7378b8, + 0x51cd958eed1ae283,0x14fe4d06de5056e6, + 0xe640faf2a8619b24,0x1a3de04895e46c9f, + 0xefe89cd7a93d00f7,0x1066ac2d5daec3e3, + 0xebe2c40d938c4134,0x14805738b51a74dc, + 0x26db7510f86f5181,0x19a06d06e2611214, + 0x9849292a9b4592f1,0x100444244d7cab4c, + 0xbe5b73754216f7ad,0x1405552d60dbd61f, + 0xadf25052929cb598,0x1906aa78b912cba7, + 0x996ee4673743e2ff,0x1f485516e7577e91, + 0xffe54ec0828a6ddf,0x138d352e5096af1a, + 0xbfdea270a32d0957,0x18708279e4bc5ae1, + 0x2fd64b0ccbf84bad,0x1e8ca3185deb719a, + 0x5de5eee7ff7b2f4c,0x1317e5ef3ab32700, + 0x755f6aa1ff59fb1f,0x17dddf6b095ff0c0, + 0x92b7454a7f3079e7,0x1dd55745cbb7ecf0, + 0x5bb28b4e8f7e4c30,0x12a5568b9f52f416, + 0xf29f2e22335ddf3c,0x174eac2e8727b11b, + 0xef46f9aac035570b,0x1d22573a28f19d62, + 0xd58c5c0ab8215667,0x123576845997025d, + 0x4aef730d6629ac01,0x16c2d4256ffcc2f5, + 0x9dab4fd0bfb41701,0x1c73892ecbfbf3b2, + 0xa28b11e277d08e60,0x11c835bd3f7d784f, + 0x8b2dd65b15c4b1f9,0x163a432c8f5cd663, + 0x6df94bf1db35de77,0x1bc8d3f7b3340bfc, + 0xc4bbcf772901ab0a,0x115d847ad000877d, + 0x35eac354f34215cd,0x15b4e5998400a95d, + 0x8365742a30129b40,0x1b221effe500d3b4, + 0xd21f689a5e0ba108,0x10f5535fef208450, + 0x6a742c0f58e894a,0x1532a837eae8a565, + 0x4851137132f22b9d,0x1a7f5245e5a2cebe, + 0xed32ac26bfd75b42,0x108f936baf85c136, + 0xa87f57306fcd3212,0x14b378469b673184, + 0xd29f2cfc8bc07e97,0x19e056584240fde5, + 0xa3a37c1dd7584f1e,0x102c35f729689eaf, + 0x8c8c5b254d2e62e6,0x14374374f3c2c65b, + 0x6faf71eea079fb9f,0x1945145230b377f2, + 0xb9b4e6a48987a87,0x1f965966bce055ef, + 0x674111026d5f4c94,0x13bdf7e0360c35b5, + 0xc111554308b71fba,0x18ad75d8438f4322, + 0x7155aa93cae4e7a8,0x1ed8d34e547313eb, + 0x26d58a9c5ecf10c9,0x13478410f4c7ec73, + 0xf08aed437682d4fb,0x1819651531f9e78f, + 0xecada89454238a3a,0x1e1fbe5a7e786173, + 0x73ec895cb4963664,0x12d3d6f88f0b3ce8, + 0x90e7abb3e1bbc3fd,0x1788ccb6b2ce0c22, + 0x352196a0da2ab4fd,0x1d6affe45f818f2b, + 0x134fe24885ab11e,0x1262dfeebbb0f97b, + 0xc1823dadaa715d65,0x16fb97ea6a9d37d9, + 0x31e2cd19150db4bf,0x1cba7de5054485d0, + 0x1f2dc02fad2890f7,0x11f48eaf234ad3a2, + 0xa6f9303b9872b535,0x1671b25aec1d888a, + 0x50b77c4a7e8f6282,0x1c0e1ef1a724eaad, + 0x5272adae8f199d91,0x1188d357087712ac, + 0x670f591a32e004f6,0x15eb082cca94d757, + 0x40d32f60bf980633,0x1b65ca37fd3a0d2d, + 0x4883fd9c77bf03e0,0x111f9e62fe44483c, + 0x5aa4fd0395aec4d8,0x156785fbbdd55a4b, + 0x314e3c447b1a760e,0x1ac1677aad4ab0de, + 0xded0e5aaccf089c9,0x10b8e0acac4eae8a, + 0x96851f15802cac3b,0x14e718d7d7625a2d, + 0xfc2666dae037d74a,0x1a20df0dcd3af0b8, + 0x9d980048cc22e68e,0x10548b68a044d673, + 0x84fe005aff2ba032,0x1469ae42c8560c10, + 0xa63d8071bef6883e,0x198419d37a6b8f14, + 0xcfcce08e2eb42a4e,0x1fe52048590672d9, + 0x21e00c58dd309a70,0x13ef342d37a407c8, + 0x2a580f6f147cc10d,0x18eb0138858d09ba, + 0xb4ee134ad99bf150,0x1f25c186a6f04c28, + 0x7114cc0ec80176d2,0x137798f428562f99, + 0xcd59ff127a01d486,0x18557f31326bbb7f, + 0xc0b07ed7188249a8,0x1e6adefd7f06aa5f, + 0xd86e4f466f516e09,0x1302cb5e6f642a7b, + 0xce89e3180b25c98b,0x17c37e360b3d351a, + 0x822c5bde0def3bee,0x1db45dc38e0c8261, + 0xf15bb96ac8b58575,0x1290ba9a38c7d17c, + 0x2db2a7c57ae2e6d2,0x1734e940c6f9c5dc, + 0x391f51b6d99ba086,0x1d022390f8b83753, + 0x3b3931248014454,0x1221563a9b732294, + 0x4a077d6da019569,0x16a9abc9424feb39, + 0x45c895cc9081fac3,0x1c5416bb92e3e607, + 0x8b9d5d9fda513cba,0x11b48e353bce6fc4, + 0xae84b507d0e58be8,0x1621b1c28ac20bb5, + 0x1a25e249c51eeee3,0x1baa1e332d728ea3, + 0xf057ad6e1b33554d,0x114a52dffc679925, + 0x6c6d98c9a2002aa1,0x159ce797fb817f6f, + 0x4788fefc0a803549,0x1b04217dfa61df4b, + 0xcb59f5d8690214e,0x10e294eebc7d2b8f, + 0xcfe30734e83429a1,0x151b3a2a6b9c7672, + 0x83dbc9022241340a,0x1a6208b50683940f, + 0xb2695da15568c086,0x107d457124123c89, + 0x1f03b509aac2f0a7,0x149c96cd6d16cbac, + 0x26c4a24c1573acd1,0x19c3bc80c85c7e97, + 0x783ae56f8d684c03,0x101a55d07d39cf1e, + 0x16499ecb70c25f03,0x1420eb449c8842e6, + 0x9bdc067e4cf2f6c4,0x19292615c3aa539f, + 0x82d3081de02fb476,0x1f736f9b3494e887, + 0xb1c3e512ac1dd0c9,0x13a825c100dd1154, + 0xde34de57572544fc,0x18922f31411455a9, + 0x55c215ed2cee963b,0x1eb6bafd91596b14, + 0xb5994db43c151de5,0x133234de7ad7e2ec, + 0xe2ffa1214b1a655e,0x17fec216198ddba7, + 0xdbbf89699de0feb6,0x1dfe729b9ff15291, + 0x2957b5e202ac9f31,0x12bf07a143f6d39b, + 0xf3ada35a8357c6fe,0x176ec98994f48881, + 0x70990c31242db8bd,0x1d4a7bebfa31aaa2, + 0x865fa79eb69c9376,0x124e8d737c5f0aa5, + 0xe7f791866443b854,0x16e230d05b76cd4e, + 0xa1f575e7fd54a669,0x1c9abd04725480a2, + 0xa53969b0fe54e801,0x11e0b622c774d065, + 0xe87c41d3dea2202,0x1658e3ab7952047f, + 0xd229b5248d64aa82,0x1bef1c9657a6859e, + 0x435a1136d85eea91,0x117571ddf6c81383, + 0x143095848e76a536,0x15d2ce55747a1864, + 0x193cbae5b2144e83,0x1b4781ead1989e7d, + 0x2fc5f4cf8f4cb112,0x110cb132c2ff630e, + 0xbbb77203731fdd56,0x154fdd7f73bf3bd1, + 0x2aa54e844fe7d4ac,0x1aa3d4df50af0ac6, + 0xdaa75112b1f0e4eb,0x10a6650b926d66bb, + 0xd15125575e6d1e26,0x14cffe4e7708c06a, + 0x85a56ead360865b0,0x1a03fde214caf085, + 0x7387652c41c53f8e,0x10427ead4cfed653, + 0x50693e7752368f71,0x14531e58a03e8be8, + 0x64838e1526c4334e,0x1967e5eec84e2ee2, + 0xfda4719a70754022,0x1fc1df6a7a61ba9a, + 0xde86c70086494815,0x13d92ba28c7d14a0, + 0x162878c0a7db9a1a,0x18cf768b2f9c59c9, + 0x5bb296f0d1d280a1,0x1f03542dfb83703b, + 0x194f9e5683239064,0x1362149cbd322625, + 0x5fa385ec23ec747e,0x183a99c3ec7eafae, + 0xf78c67672ce7919d,0x1e494034e79e5b99, + 0x3ab7c0a07c10bb02,0x12edc82110c2f940, + 0x4965b0c89b14e9c3,0x17a93a2954f3b790, + 0x5bbf1cfac1da2433,0x1d9388b3aa30a574, + 0xb957721cb92856a0,0x127c35704a5e6768, + 0xe7ad4ea3e7726c48,0x171b42cc5cf60142, + 0xa198a24ce14f075a,0x1ce2137f74338193, + 0x44ff65700cd16498,0x120d4c2fa8a030fc, + 0x563f3ecc1005bdbe,0x16909f3b92c83d3b, + 0x2bcf0e7f14072d2e,0x1c34c70a777a4c8a, + 0x5b61690f6c847c3d,0x11a0fc668aac6fd6, + 0xf239c35347a59b4c,0x16093b802d578bcb, + 0xeec83428198f021f,0x1b8b8a6038ad6ebe, + 0x553d20990ff96153,0x1137367c236c6537, + 0x2a8c68bf53f7b9a8,0x1585041b2c477e85, + 0x752f82ef28f5a812,0x1ae64521f7595e26, + 0x93db1d57999890b,0x10cfeb353a97dad8, + 0xb8d1e4ad7ffeb4e,0x1503e602893dd18e, + 0x8e7065dd8dffe622,0x1a44df832b8d45f1, + 0xf9063faa78bfefd5,0x106b0bb1fb384bb6, + 0xb747cf9516efebca,0x1485ce9e7a065ea4, + 0xe519c37a5cabe6bd,0x19a742461887f64d, + 0xaf301a2c79eb7036,0x1008896bcf54f9f0, + 0xdafc20b798664c43,0x140aabc6c32a386c, + 0x11bb28e57e7fdf54,0x190d56b873f4c688, + 0x1629f31ede1fd72a,0x1f50ac6690f1f82a, + 0x4dda37f34ad3e67a,0x13926bc01a973b1a, + 0xe150c5f01d88e019,0x187706b0213d09e0, + 0x19a4f76c24eb181f,0x1e94c85c298c4c59, + 0xb0071aa39712ef13,0x131cfd3999f7afb7, + 0x9c08e14c7cd7aad8,0x17e43c8800759ba5, + 0x30b199f9c0d958e,0x1ddd4baa0093028f, + 0x61e6f003c1887d79,0x12aa4f4a405be199, + 0xba60ac04b1ea9cd7,0x1754e31cd072d9ff, + 0xa8f8d705de65440d,0x1d2a1be4048f907f, + 0xc99b8663aaff4a88,0x123a516e82d9ba4f, + 0xbc0267fc95bf1d2a,0x16c8e5ca239028e3, + 0xab0301fbbb2ee474,0x1c7b1f3cac74331c, + 0xeae1e13d54fd4ec9,0x11ccf385ebc89ff1, + 0x659a598caa3ca27b,0x1640306766bac7ee, + 0xff00efefd4cbcb1a,0x1bd03c81406979e9, + 0x3f6095f5e4ff5ef0,0x116225d0c841ec32, + 0xcf38bb735e3f36ac,0x15baaf44fa52673e, + 0x8306ea5035cf0457,0x1b295b1638e7010e, + 0x11e4527221a162b6,0x10f9d8ede39060a9, + 0x565d670eaa09bb64,0x15384f295c7478d3, + 0x2bf4c0d2548c2a3d,0x1a8662f3b3919708, + 0x1b78f88374d79a66,0x1093fdd8503afe65, + 0x625736a4520d8100,0x14b8fd4e6449bdfe, + 0xfaed044d6690e140,0x19e73ca1fd5c2d7d, + 0xbcd422b0601a8cc8,0x103085e53e599c6e, + 0x6c092b5c78212ffa,0x143ca75e8df0038a, + 0x70b763396297bf8,0x194bd136316c046d, + 0x48ce53c07bb3daf6,0x1f9ec583bdc70588, + 0x2d80f4584d5068da,0x13c33b72569c6375, + 0x78e1316e60a48310,0x18b40a4eec437c52 +}; diff --git a/cbits/fpstring.c b/cbits/fpstring.c --- a/cbits/fpstring.c +++ b/cbits/fpstring.c @@ -29,12 +29,23 @@ * SUCH DAMAGE. */ +#include "HsFFI.h" +#include "MachDeps.h" + #include "fpstring.h" #if defined(__x86_64__) -#include -#include +#include +#include #endif +#include +#include + +#if defined(__x86_64__) && (__GNUC__ >= 7 || __GNUC__ == 6 && __GNUC_MINOR__ >= 3 || defined(__clang_major__)) && !defined(__STDC_NO_ATOMICS__) +#include +#define USE_SIMD_COUNT +#endif + /* copy a string in reverse */ void fps_reverse(unsigned char *q, unsigned char *p, size_t n) { p += n-1; @@ -90,26 +101,218 @@ return c; } -/* count the number of occurences of a char in a string */ -size_t fps_count(unsigned char *p, size_t len, unsigned char 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; ++p) - if (*p == w) + for (c = 0; len-- != 0; ++str) + if (*str == w) ++c; return c; } -/* This wrapper is here so that we can copy a sub-range of a ByteArray#. - We cannot construct a pointer to the interior of an unpinned ByteArray#, - except by doing an unsafe ffi call, and adjusting the pointer C-side. */ -void * fps_memcpy_offsets(void *dst, size_t dst_off, const void *src, size_t src_off, size_t n) { - return memcpy(dst + dst_off, src + src_off, n); + +#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; } -int fps_compare(const void *a, const void *b) { - return (int)*(unsigned char*)a - (int)*(unsigned char*)b; +__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; } -void fps_sort(unsigned char *p, size_t len) { - return qsort(p, len, 1, fps_compare); +typedef size_t (*fps_impl_t) (unsigned char*, size_t, unsigned char); + +fps_impl_t select_fps_simd_impl() { + uint32_t eax = 0, ebx = 0, ecx = 0, edx = 0; + + uint32_t ecx1 = 0; + if (__get_cpuid(1, &eax, &ebx, &ecx, &edx)) { + ecx1 = ecx; + } + + const bool has_xsave = ecx1 & (1 << 26); + const bool has_popcnt = ecx1 & (1 << 23); + + if (__get_cpuid_count(7, 0, &eax, &ebx, &ecx, &edx)) { + const bool has_avx2 = has_xsave && (ebx & (1 << 5)); + if (has_avx2 && has_popcnt) { + return &fps_count_avx2; + } + } + + const bool has_sse42 = ecx1 & (1 << 19); + if (has_sse42 && has_popcnt) { + return &fps_count_cmpestrm; + } + + return &fps_count_naive; +} +#endif + + + +size_t fps_count(unsigned char *str, size_t len, unsigned char w) { +#ifndef USE_SIMD_COUNT + return fps_count_naive(str, len, w); +#else + // 1024 is a rough guesstimate of the string length + // for which the extra performance of the main SIMD loop + // starts to compensate the extra work and extra branching outside the SIMD loop. + // The real optimal number depends on the specific μarch + // and isn't worth optimizing for in this context, + // since counting characters in shorter strings is unlikely to be a hot spot. + if (len <= 1024) { + return fps_count_naive(str, len, w); + } + + static _Atomic fps_impl_t s_impl = (fps_impl_t)NULL; + fps_impl_t impl = atomic_load_explicit(&s_impl, memory_order_relaxed); + if (!impl) { + impl = select_fps_simd_impl(); + atomic_store_explicit(&s_impl, impl, memory_order_relaxed); + } + + return (*impl)(str, len, w); +#endif } diff --git a/cbits/is-valid-utf8.c b/cbits/is-valid-utf8.c new file mode 100644 --- /dev/null +++ b/cbits/is-valid-utf8.c @@ -0,0 +1,782 @@ +/* +Copyright (c) Koz Ross 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. +*/ +#pragma GCC push_options +#pragma GCC optimize("-O2") +#include +#include +#include +#include + +#ifdef __x86_64__ +#include +#include +#include +#if (__GNUC__ >= 7 || __GNUC__ == 6 && __GNUC_MINOR__ >= 3 || \ + defined(__clang_major__)) && \ + !defined(__STDC_NO_ATOMICS__) +#include +#include +#else +// This is needed to support CentOS 7, which has a very old GCC. +#define CRUFTY_GCC +#endif +#endif + +#include +#include "ghcplatform.h" + +#ifdef WORDS_BIGENDIAN +#define to_little_endian(x) __builtin_bswap64(x) +#else +#define to_little_endian(x) (x) +#endif + +// 0x80 in every 'lane'. +static uint64_t const high_bits_mask = 0x8080808080808080ULL; + +static inline uint64_t read_uint64(const uint64_t *p) { + uint64_t r; + memcpy(&r, p, 8); + return r; +} + +// stand-in for __builtin_ctzll, used because __builtin_ctzll can +// cause runtime linker issues for GHC in some exotic situations (#601) +// +// See also these ghc issues: +// * https://gitlab.haskell.org/ghc/ghc/-/issues/21787 +// * https://gitlab.haskell.org/ghc/ghc/-/issues/22011 +static inline int hs_bytestring_ctz64(const uint64_t x) { + // These CPP conditions are taken from ghc-prim: + // https://gitlab.haskell.org/ghc/ghc/-/blob/73b5c7ce33929e1f7c9283ed7c2860aa40f6d0ec/libraries/ghc-prim/cbits/ctz.c#L31-57 + // credit to Herbert Valerio Riedel, Erik de Castro Lopo +#if defined(__GNUC__) && (defined(i386_HOST_ARCH) || defined(powerpc_HOST_ARCH)) + uint32_t xhi = (uint32_t)(x >> 32); + uint32_t xlo = (uint32_t) x; + return xlo ? __builtin_ctz(xlo) : 32 + __builtin_ctz(xhi); +#elif SIZEOF_UNSIGNED_LONG == 8 + return __builtin_ctzl(x); +#elif SIZEOF_UNSIGNED_LONG_LONG == 8 + return __builtin_ctzll(x); +#else +# error no suitable __builtin_ctz() found +#endif +} + +static inline int is_valid_utf8_fallback(uint8_t const *const src, + size_t const len) { + uint8_t const *ptr = (uint8_t const *)src; + // This is 'one past the end' to make loop termination and bounds checks + // easier. + uint8_t const *const end = ptr + len; + while (ptr < end) { + uint8_t const byte = *ptr; + // Check if the byte is ASCII. + if (byte <= 0x7F) { + ptr++; + // If we saw one ASCII byte, as long as it's not whitespace, it's quite + // likely we'll see more. + bool is_not_whitespace = byte > 32; + // If possible, do a block-check ahead. + if ((ptr + 32 < end) && is_not_whitespace) { + uint64_t const *big_ptr = (uint64_t const *)ptr; + // Non-ASCII bytes have a set MSB. Thus, if we AND with 0x80 in every + // 'lane', we will get 0 if everything is ASCII, and something else + // otherwise. + uint64_t results[4] = { + to_little_endian(read_uint64(big_ptr)) & high_bits_mask, + to_little_endian(read_uint64((big_ptr + 1))) & high_bits_mask, + to_little_endian(read_uint64((big_ptr + 2))) & high_bits_mask, + to_little_endian(read_uint64((big_ptr + 3))) & high_bits_mask}; + if (results[0] == 0) { + ptr += 8; + if (results[1] == 0) { + ptr += 8; + if (results[2] == 0) { + ptr += 8; + if (results[3] == 0) { + ptr += 8; + } else { + ptr += (hs_bytestring_ctz64(results[3]) / 8); + } + } else { + ptr += (hs_bytestring_ctz64(results[2]) / 8); + } + } else { + ptr += (hs_bytestring_ctz64(results[1]) / 8); + } + } else { + ptr += (hs_bytestring_ctz64(results[0]) / 8); + } + } + } + // Check for a valid 2-byte sequence. + // + // We use a signed comparison to avoid an extra comparison with 0x80, since + // _signed_ 0x80 is -128. + else if (ptr + 1 < end && byte >= 0xC2 && byte <= 0xDF && + ((int8_t) * (ptr + 1)) <= (int8_t)0xBF) { + ptr += 2; + } + // Check for a valid 3-byte sequence. + else if (ptr + 2 < end && byte >= 0xE0 && byte <= 0xEF) { + uint8_t const byte2 = *(ptr + 1); + bool byte2_valid = (int8_t)byte2 <= (int8_t)0xBF; + bool byte3_valid = ((int8_t) * (ptr + 2)) <= (int8_t)0xBF; + if (byte2_valid && byte3_valid && + // E0, A0..BF, 80..BF + ((byte == 0xE0 && byte2 >= 0xA0) || + // E1..EC, 80..BF, 80..BF + (byte >= 0xE1 && byte <= 0xEC) || + // ED, 80..9F, 80..BF + (byte == 0xED && byte2 <= 0x9F) || + // EE..EF, 80..BF, 80..BF + (byte >= 0xEE && byte <= 0xEF))) { + ptr += 3; + } else { + return 0; + } + } + // Check for a valid 4-byte sequence. + else if (ptr + 3 < end) { + uint8_t const byte2 = *(ptr + 1); + bool byte2_valid = (int8_t)byte2 <= (int8_t)0xBF; + bool byte3_valid = ((int8_t) * (ptr + 2)) <= (int8_t)0xBF; + bool byte4_valid = ((int8_t) * (ptr + 3)) <= (int8_t)0xBF; + if (byte2_valid && byte3_valid && byte4_valid && + // F0, 90..BF, 80..BF, 80..BF + ((byte == 0xF0 && byte2 >= 0x90) || + // F1..F3, 80..BF, 80..BF, 80..BF + (byte >= 0xF1 && byte <= 0xF3) || + // F4, 80..8F, 80..BF, 80..BF + (byte == 0xF4 && byte2 <= 0x8F))) { + ptr += 4; + } else { + return 0; + } + } + // Otherwise, invalid. + else { + return 0; + } + } + // If we got this far, we're valid. + return 1; +} + +#if defined(__x86_64__) && !defined(CRUFTY_GCC) + +// SSE2 + +static inline int is_valid_utf8_sse2(uint8_t const *const src, + size_t const len) { + uint8_t const *ptr = (uint8_t const *)src; + // This is 'one past the end' to make loop termination and bounds checks + // easier. + uint8_t const *const end = ptr + len; + while (ptr < end) { + uint8_t const byte = *ptr; + // Check if the byte is ASCII. + if (byte <= 0x7F) { + ptr++; + // If we saw one ASCII byte, as long as it's not whitespace, it's quite + // likely we'll see more. + bool is_not_whitespace = byte > 32; + // If possible, do a block-check ahead. + if ((ptr + 64 < end) && is_not_whitespace) { + __m128i const *big_ptr = (__m128i const *)ptr; + // Non-ASCII bytes have a set MSB. Thus, if we evacuate the MSBs, we + // will get a set bit somewhere if there's a non-ASCII byte in that + // block. + uint16_t result = _mm_movemask_epi8(_mm_loadu_si128(big_ptr)); + if (result == 0) { + ptr += 16; + // Try one more. + result = _mm_movemask_epi8(_mm_loadu_si128(big_ptr + 1)); + if (result == 0) { + ptr += 16; + // And one more. + result = _mm_movemask_epi8(_mm_loadu_si128(big_ptr + 2)); + if (result == 0) { + ptr += 16; + // Last one. + result = _mm_movemask_epi8(_mm_loadu_si128(big_ptr + 3)); + if (result == 0) { + ptr += 16; + } else { + ptr += __builtin_ctz(result); + } + } else { + ptr += __builtin_ctz(result); + } + } else { + ptr += __builtin_ctz(result); + } + } else { + ptr += __builtin_ctz(result); + } + } + } + // Check for a valid 2-byte sequence. + // + // We use a signed comparison to avoid an extra comparison with 0x80, since + // _signed_ 0x80 is -128. + else if (ptr + 1 < end && byte >= 0xC2 && byte <= 0xDF && + ((int8_t) * (ptr + 1)) <= (int8_t)0xBF) { + ptr += 2; + } + // Check for a valid 3-byte sequence. + else if (ptr + 2 < end) { + uint8_t const byte2 = *(ptr + 1); + bool byte2_valid = (int8_t)byte2 <= (int8_t)0xBF; + bool byte3_valid = ((int8_t) * (ptr + 2)) <= (int8_t)0xBF; + if (byte2_valid && byte3_valid && + // E0, A0..BF, 80..BF + ((byte == 0xE0 && byte2 >= 0xA0) || + // E1..EC, 80..BF, 80..BF + (byte >= 0xE1 && byte <= 0xEC) || + // ED, 80..9F, 80..BF + (byte == 0xED && byte2 <= 0x9F) || + // EE..EF, 80..BF, 80..BF + (byte >= 0xEE && byte <= 0xEF))) { + ptr += 3; + } else { + return 0; + } + } + // Check for a valid 4-byte sequence. + else if (ptr + 3 < end) { + uint8_t const byte2 = *(ptr + 1); + bool byte2_valid = (int8_t)byte2 <= (int8_t)0xBF; + bool byte3_valid = ((int8_t) * (ptr + 2)) <= (int8_t)0xBF; + bool byte4_valid = ((int8_t) * (ptr + 3)) <= (int8_t)0xBF; + if (byte2_valid && byte3_valid && byte4_valid && + // F0, 90..BF, 80..BF, 80..BF + ((byte == 0xF0 && byte2 >= 0x90) || + // F1..F3, 80..BF, 80..BF, 80..BF + (byte >= 0xF1 && byte <= 0xF3) || + // F4, 80..8F, 80..BF, 80..BF + (byte == 0xF4 && byte2 <= 0x8F))) { + ptr += 4; + } else { + return 0; + } + } + // Otherwise, invalid. + else { + return 0; + } + } + // If we got this far, we're valid. + return 1; +} + +// SSSE3 + +// Lookup tables + +// Map high nibble the first byte to legal character length minus 1 +// [0x00, 0xBF] --> 0 +// [0xC0, 0xDF] --> 1 +// [0xE0, 0xEF] --> 2 +// [0xF0, 0xFF] --> 3 +static int8_t const first_len_lookup[16] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 2, 3, +}; + +// Map first byte to 8th item of range table if it's in [0xC2, 0xF4] +static int8_t const first_range_lookup[16] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 8, 8, +}; + +// Range tables, mapping range index to min and max values +// Index 0 : 00 ~ 7F (First Byte, ascii) +// Index 1,2,3: 80 ~ BF (Second, Third, Fourth Byte) +// Index 4 : A0 ~ BF (Second Byte after E0) +// Index 5 : 80 ~ 9F (Second Byte after ED) +// Index 6 : 90 ~ BF (Second Byte after F0) +// Index 7 : 80 ~ 8F (Second Byte after F4) +// Index 8 : C2 ~ F4 (First Byte, non ascii) +// Index 9~15 : illegal: i >= 127 && i <= -128 +static int8_t const range_min_lookup[16] = { + 0x00, 0x80, 0x80, 0x80, 0xA0, 0x80, 0x90, 0x80, + 0xC2, 0x7F, 0x7F, 0x7F, 0x7F, 0x7F, 0x7F, 0x7F, +}; + +static int8_t const range_max_lookup[16] = { + 0x7F, 0xBF, 0xBF, 0xBF, 0xBF, 0x9F, 0xBF, 0x8F, + 0xF4, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, +}; + +// Tables for fast handling of four special First Bytes(E0,ED,F0,F4), after +// which the Second Byte are not 80~BF. It contains "range index adjustment". +// +------------+---------------+------------------+----------------+ +// | First Byte | original range| range adjustment | adjusted range | +// +------------+---------------+------------------+----------------+ +// | E0 | 2 | 2 | 4 | +// +------------+---------------+------------------+----------------+ +// | ED | 2 | 3 | 5 | +// +------------+---------------+------------------+----------------+ +// | F0 | 3 | 3 | 6 | +// +------------+---------------+------------------+----------------+ +// | F4 | 3 | 4 | 7 | +// +------------+---------------+------------------+----------------+ +// index1 -> E0, index14 -> ED +static int8_t const df_ee_lookup[16] = { + 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, +}; + +// index1 -> F0, index5 -> F4 +static int8_t const ef_fe_lookup[16] = { + 0, 3, 0, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, +}; + +__attribute__((target("ssse3"))) static inline bool +is_ascii_sse2(__m128i const *src, __m128i const prev_first_len) { + // Check if we have ASCII, and also that we don't have to treat the prior + // block as special. + // First, verify that we didn't see any non-ASCII bytes in the first half of + // the stride. + __m128i const first_half_clean = _mm_or_si128(src[0], src[1]); + // Then do the same for the second half of the stride. + __m128i const second_half_clean = _mm_or_si128(src[2], src[3]); + // Check cleanliness of the entire stride. + __m128i const stride_clean = + _mm_or_si128(first_half_clean, second_half_clean); + // Finally, check that we didn't have any leftover marker bytes in the + // previous block: these are indicated by non-zeroes in prev_first_len. In + // order to trigger a failure, we have to have non-zeros set the high bit of + // the lane: we do this by doing a greater-than comparison with a block of + // zeroes. + __m128i const no_prior_dirt = + _mm_cmpgt_epi8(prev_first_len, _mm_setzero_si128()); + // OR together everything, then check for a high bit anywhere. + __m128i const ored = _mm_or_si128(stride_clean, no_prior_dirt); + return (_mm_movemask_epi8(ored) == 0); +} + +__attribute__((target("ssse3"))) static inline __m128i +high_nibbles_of(__m128i const src) { + return _mm_and_si128(_mm_srli_epi16(src, 4), _mm_set1_epi8(0x0F)); +} + +__attribute__((target("ssse3"))) static inline __m128i +check_block_sse3(__m128i prev_input, __m128i prev_first_len, + __m128i const errors, __m128i const first_range_tbl, + __m128i const range_min_tbl, __m128i const range_max_tbl, + __m128i const df_ee_tbl, __m128i const ef_fe_tbl, + __m128i const input, __m128i const first_len) { + // Get the high 4-bits of the input. + __m128i const high_nibbles = + _mm_and_si128(_mm_srli_epi16(input, 4), _mm_set1_epi8(0x0F)); + // Set range index to 8 for bytes in [C0, FF] by lookup (first byte). + __m128i range = _mm_shuffle_epi8(first_range_tbl, high_nibbles); + // Reduce the range index based on first_len (second byte) + // This is 0 for [00, 7F], 1 for [C0, DF], 2 for [E0, EF], 3 for [F0, FF]. + range = _mm_or_si128(range, _mm_alignr_epi8(first_len, prev_first_len, 15)); + // Set range index to the saturation of (first_len - 1) (third byte). + // This is 0 for [00, 7F], 0 for [C0, DF], 1 for [E0, EF], 2 for [F0, FF]. + __m128i tmp = _mm_alignr_epi8(first_len, prev_first_len, 14); + tmp = _mm_subs_epu8(tmp, _mm_set1_epi8(1)); + range = _mm_or_si128(range, tmp); + // Set range index to the saturation of (first_len - 2) (fourth byte). + // This is 0 for [00, 7F], 0 for [C0, DF], 0 for [E0, EF] and 1 for [F0, FF]. + tmp = _mm_alignr_epi8(first_len, prev_first_len, 13); + tmp = _mm_subs_epu8(tmp, _mm_set1_epi8(2)); + range = _mm_or_si128(range, tmp); + // At this stage, we have calculated range indices correctly, except for + // special cases for first bytes (E0, ED, F0, F4). We repair this to avoid + // missing in the range table. + __m128i const shift1 = _mm_alignr_epi8(input, prev_input, 15); + __m128i const pos = _mm_sub_epi8(shift1, _mm_set1_epi8(0xEF)); + tmp = _mm_subs_epu8(pos, _mm_set1_epi8(0xF0)); + __m128i range2 = _mm_shuffle_epi8(df_ee_tbl, tmp); + tmp = _mm_adds_epu8(pos, _mm_set1_epi8(0x70)); + range2 = _mm_add_epi8(range2, _mm_shuffle_epi8(ef_fe_tbl, tmp)); + range = _mm_add_epi8(range, range2); + // We can now load minimum and maximum values from our tables based on the + // calculated indices. + __m128i const minv = _mm_shuffle_epi8(range_min_tbl, range); + __m128i const maxv = _mm_shuffle_epi8(range_max_tbl, range); + // Calculate the error (if any). + tmp = _mm_or_si128(_mm_cmplt_epi8(input, minv), _mm_cmpgt_epi8(input, maxv)); + // Accumulate error. + return _mm_or_si128(errors, tmp); +} + +__attribute__((target("ssse3"))) static inline int +is_valid_utf8_ssse3(uint8_t const *const src, size_t const len) { + // We stride 64 bytes at a time. + size_t const big_strides = len / 64; + size_t const remaining = len % 64; + uint8_t const *ptr = (uint8_t const *)src; + // Tracking state. + __m128i prev_input = _mm_setzero_si128(); + __m128i prev_first_len = _mm_setzero_si128(); + __m128i errors = _mm_setzero_si128(); + for (size_t i = 0; i < big_strides; i++) { + // Pre-load tables. + __m128i const first_len_tbl = + _mm_loadu_si128((__m128i const *)first_len_lookup); + __m128i const first_range_tbl = + _mm_loadu_si128((__m128i const *)first_range_lookup); + __m128i const range_min_tbl = + _mm_loadu_si128((__m128i const *)range_min_lookup); + __m128i const range_max_tbl = + _mm_loadu_si128((__m128i const *)range_max_lookup); + __m128i const df_ee_tbl = _mm_loadu_si128((__m128i const *)df_ee_lookup); + __m128i const ef_fe_tbl = _mm_loadu_si128((__m128i const *)ef_fe_lookup); + // Load 64 bytes. + __m128i const *big_ptr = (__m128i const *)ptr; + __m128i const inputs[4] = { + _mm_loadu_si128(big_ptr), _mm_loadu_si128(big_ptr + 1), + _mm_loadu_si128(big_ptr + 2), _mm_loadu_si128(big_ptr + 3)}; + // Check if we have ASCII. + if (is_ascii_sse2(inputs, prev_first_len)) { + // Prev_first_len cheaply. + prev_first_len = + _mm_shuffle_epi8(first_len_tbl, high_nibbles_of(inputs[3])); + } else { + __m128i first_len = + _mm_shuffle_epi8(first_len_tbl, high_nibbles_of(inputs[0])); + errors = check_block_sse3(prev_input, prev_first_len, errors, + first_range_tbl, range_min_tbl, range_max_tbl, + df_ee_tbl, ef_fe_tbl, inputs[0], first_len); + prev_first_len = first_len; + first_len = _mm_shuffle_epi8(first_len_tbl, high_nibbles_of(inputs[1])); + errors = check_block_sse3(inputs[0], prev_first_len, errors, + first_range_tbl, range_min_tbl, range_max_tbl, + df_ee_tbl, ef_fe_tbl, inputs[1], first_len); + prev_first_len = first_len; + first_len = _mm_shuffle_epi8(first_len_tbl, high_nibbles_of(inputs[2])); + errors = check_block_sse3(inputs[1], prev_first_len, errors, + first_range_tbl, range_min_tbl, range_max_tbl, + df_ee_tbl, ef_fe_tbl, inputs[2], first_len); + prev_first_len = first_len; + first_len = _mm_shuffle_epi8(first_len_tbl, high_nibbles_of(inputs[3])); + errors = check_block_sse3(inputs[2], prev_first_len, errors, + first_range_tbl, range_min_tbl, range_max_tbl, + df_ee_tbl, ef_fe_tbl, inputs[3], first_len); + prev_first_len = first_len; + } + // Set prev_input based on last block. + prev_input = inputs[3]; + // Advance. + ptr += 64; + } + // Write out the error, check if it's OK. + uint64_t results[2]; + _mm_storeu_si128((__m128i *)results, errors); + if (results[0] != 0 || results[1] != 0) { + return 0; + } + // 'Roll back' our pointer a little to prepare for a slow search of the rest. + uint16_t tokens[2]; + tokens[0] = _mm_extract_epi16(prev_input, 6); + tokens[1] = _mm_extract_epi16(prev_input, 7); + uint8_t const *token_ptr = (uint8_t const *)tokens; + ptrdiff_t rollback = 0; + // We must not roll back if no big blocks were processed, as then + // the fallback function would examine out-of-bounds data (#620). + // In that case, prev_input contains only nulls and we skip the if body. + if (token_ptr[3] >= 0x80u) { + // Look for an incomplete multi-byte code point + if (token_ptr[3] >= 0xC0u) { + rollback = 1; + } else if (token_ptr[2] >= 0xE0u) { + rollback = 2; + } else if (token_ptr[1] >= 0xF0u) { + rollback = 3; + } + } + // Finish the job. + uint8_t const *const small_ptr = ptr - rollback; + size_t const small_len = remaining + rollback; + return is_valid_utf8_fallback(small_ptr, small_len); +} + +// AVX2 +// +// These work similarly to the SSSE3 version, but with registers twice the +// width. + +static int8_t const first_len_lookup2[32] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 2, 3, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 2, 3, +}; + +static int8_t const first_range_lookup2[32] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 8, 8, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 8, 8, +}; + +static int8_t const range_min_lookup2[32] = { + 0x00, 0x80, 0x80, 0x80, 0xA0, 0x80, 0x90, 0x80, 0xC2, 0x7F, 0x7F, + 0x7F, 0x7F, 0x7F, 0x7F, 0x7F, 0x00, 0x80, 0x80, 0x80, 0xA0, 0x80, + 0x90, 0x80, 0xC2, 0x7F, 0x7F, 0x7F, 0x7F, 0x7F, 0x7F, 0x7F, +}; + +static int8_t const range_max_lookup2[32] = { + 0x7F, 0xBF, 0xBF, 0xBF, 0xBF, 0x9F, 0xBF, 0x8F, 0xF4, 0x80, 0x80, + 0x80, 0x80, 0x80, 0x80, 0x80, 0x7F, 0xBF, 0xBF, 0xBF, 0xBF, 0x9F, + 0xBF, 0x8F, 0xF4, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, +}; + +static int8_t const df_ee_lookup2[32] = { + 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, + 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, +}; + +static int8_t const ef_fe_lookup2[32] = { + 0, 3, 0, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 3, 0, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, +}; + +__attribute__((target("avx,avx2"))) static inline __m256i +high_nibbles_of_avx2(__m256i const src) { + return _mm256_and_si256(_mm256_srli_epi16(src, 4), _mm256_set1_epi8(0x0F)); +} + +__attribute__((target("avx,avx2"))) static inline __m256i +push_last_byte_of_a_to_b(__m256i const a, __m256i const b) { + return _mm256_alignr_epi8(b, _mm256_permute2x128_si256(a, b, 0x21), 15); +} + +__attribute__((target("avx,avx2"))) static inline __m256i +push_last_2bytes_of_a_to_b(__m256i const a, __m256i const b) { + return _mm256_alignr_epi8(b, _mm256_permute2x128_si256(a, b, 0x21), 14); +} + +__attribute__((target("avx,avx2"))) static inline __m256i +push_last_3bytes_of_a_to_b(__m256i const a, __m256i const b) { + return _mm256_alignr_epi8(b, _mm256_permute2x128_si256(a, b, 0x21), 13); +} + +__attribute__((target("avx,avx2"))) static inline void +check_block_avx2(__m256i const prev_input, __m256i const prev_first_len, + __m256i *errors, __m256i const first_range_tbl, + __m256i const range_min_tbl, __m256i const range_max_tbl, + __m256i const df_ee_tbl, __m256i const ef_fe_tbl, + __m256i const input, __m256i const first_len) { + // Set range index to 8 for bytes in [C0, FF] by lookup (first byte). + __m256i range = + _mm256_shuffle_epi8(first_range_tbl, high_nibbles_of_avx2(input)); + // Reduce the range index based on first_len (second byte) + // This is 0 for [00, 7F], 1 for [C0, DF], 2 for [E0, EF], 3 for [F0, FF]. + range = _mm256_or_si256(range, + push_last_byte_of_a_to_b(prev_first_len, first_len)); + // Set range index to the saturation of (first_len - 1) (third byte). + // This is 0 for [00, 7F], 0 for [C0, DF], 1 for [E0, EF], 2 for [F0, FF]. + __m256i tmp1 = push_last_2bytes_of_a_to_b(prev_first_len, first_len); + __m256i tmp2 = _mm256_subs_epu8(tmp1, _mm256_set1_epi8(0x01)); + range = _mm256_or_si256(range, tmp2); + // Set range index to the saturation of (first_len - 2) (fourth byte). + tmp1 = push_last_3bytes_of_a_to_b(prev_first_len, first_len); + tmp2 = _mm256_subs_epu8(tmp1, _mm256_set1_epi8(0x02)); + range = _mm256_or_si256(range, tmp2); + // At this stage, we have calculated range indices correctly, except for + // special cases for first bytes (E0, ED, F0, F4). We repair this to avoid + // missing in the range table. + __m256i const shift1 = push_last_byte_of_a_to_b(prev_input, input); + __m256i pos = _mm256_sub_epi8(shift1, _mm256_set1_epi8(0xEF)); + tmp1 = _mm256_subs_epu8(pos, _mm256_set1_epi8(0xF0)); + __m256i range2 = _mm256_shuffle_epi8(df_ee_tbl, tmp1); + tmp2 = _mm256_adds_epu8(pos, _mm256_set1_epi8(0x70)); + range2 = _mm256_add_epi8(range2, _mm256_shuffle_epi8(ef_fe_tbl, tmp2)); + range = _mm256_add_epi8(range, range2); + // We can now load minimum and maximum values from our tables based on the + // calculated indices. + __m256i const minv = _mm256_shuffle_epi8(range_min_tbl, range); + __m256i const maxv = _mm256_shuffle_epi8(range_max_tbl, range); + // Calculate the error, if any. + errors[0] = _mm256_or_si256(errors[0], _mm256_cmpgt_epi8(minv, input)); + errors[1] = _mm256_or_si256(errors[1], _mm256_cmpgt_epi8(input, maxv)); +} + +__attribute__((target("avx,avx2"))) static inline int +is_valid_utf8_avx2(uint8_t const *const src, size_t const len) { + // We stride 128 bytes at a time. + size_t const big_strides = len / 128; + size_t const remaining = len % 128; + uint8_t const *ptr = (uint8_t const *)src; + // Tracking state. + __m256i prev_input = _mm256_setzero_si256(); + __m256i prev_first_len = _mm256_setzero_si256(); + __m256i errors[2] = {_mm256_setzero_si256(), _mm256_setzero_si256()}; + for (size_t i = 0; i < big_strides; i++) { + // Pre-load tables. + __m256i const first_len_tbl = + _mm256_loadu_si256((__m256i const *)first_len_lookup2); + __m256i const first_range_tbl = + _mm256_loadu_si256((__m256i const *)first_range_lookup2); + __m256i const range_min_tbl = + _mm256_loadu_si256((__m256i const *)range_min_lookup2); + __m256i const range_max_tbl = + _mm256_loadu_si256((__m256i const *)range_max_lookup2); + __m256i const df_ee_tbl = + _mm256_loadu_si256((__m256i const *)df_ee_lookup2); + __m256i const ef_fe_tbl = + _mm256_loadu_si256((__m256i const *)ef_fe_lookup2); + // Load 128 bytes. + __m256i const *big_ptr = (__m256i const *)ptr; + __m256i const inputs[4] = { + _mm256_loadu_si256(big_ptr), _mm256_loadu_si256(big_ptr + 1), + _mm256_loadu_si256(big_ptr + 2), _mm256_loadu_si256(big_ptr + 3)}; + // Check if we have ASCII, and also that we don't have to treat the prior + // block as special. + // First, verify that we didn't see any non-ASCII bytes in the first half of + // the stride. + __m256i const first_half_clean = _mm256_or_si256(inputs[0], inputs[1]); + // Then do the same for the second half of the stride. + __m256i const second_half_clean = _mm256_or_si256(inputs[2], inputs[3]); + // Check cleanliness of the entire stride. + __m256i const stride_clean = + _mm256_or_si256(first_half_clean, second_half_clean); + // Finally, check that we didn't have any leftover marker bytes in the + // previous block: these are indicated by non-zeroes in prev_first_len. + // In order to trigger a failure, we have to have non-zeros set the high bit + // of the lane: we do this by doing a greater-than comparison with a block + // of zeroes. + __m256i const no_prior_dirt = + _mm256_cmpgt_epi8(prev_first_len, _mm256_setzero_si256()); + // Combine all checks together, and check if any high bits are set. + bool is_ascii = + _mm256_movemask_epi8(_mm256_or_si256(stride_clean, no_prior_dirt)) == 0; + if (is_ascii) { + // Prev_first_len cheaply + prev_first_len = + _mm256_shuffle_epi8(first_len_tbl, high_nibbles_of_avx2(inputs[3])); + } else { + __m256i first_len = + _mm256_shuffle_epi8(first_len_tbl, high_nibbles_of_avx2(inputs[0])); + check_block_avx2(prev_input, prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, df_ee_tbl, ef_fe_tbl, + inputs[0], first_len); + prev_first_len = first_len; + first_len = + _mm256_shuffle_epi8(first_len_tbl, high_nibbles_of_avx2(inputs[1])); + check_block_avx2(inputs[0], prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, df_ee_tbl, ef_fe_tbl, + inputs[1], first_len); + prev_first_len = first_len; + first_len = + _mm256_shuffle_epi8(first_len_tbl, high_nibbles_of_avx2(inputs[2])); + check_block_avx2(inputs[1], prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, df_ee_tbl, ef_fe_tbl, + inputs[2], first_len); + prev_first_len = first_len; + first_len = + _mm256_shuffle_epi8(first_len_tbl, high_nibbles_of_avx2(inputs[3])); + check_block_avx2(inputs[2], prev_first_len, errors, first_range_tbl, + range_min_tbl, range_max_tbl, df_ee_tbl, ef_fe_tbl, + inputs[3], first_len); + prev_first_len = first_len; + } + // Set prev_input based on last block. + prev_input = inputs[3]; + // Advance. + ptr += 128; + } + // Write out the error, check if it's OK. + __m256i const combined_errors = _mm256_or_si256(errors[0], errors[1]); + if (_mm256_testz_si256(combined_errors, combined_errors) != 1) { + return 0; + } + // 'Roll back' our pointer a little to prepare for a slow search of the rest. + uint32_t tokens_blob = _mm256_extract_epi32(prev_input, 7); + uint8_t const *token_ptr = (uint8_t const *)&tokens_blob; + ptrdiff_t rollback = 0; + // We must not roll back if no big blocks were processed, as then + // the fallback function would examine out-of-bounds data (#620). + // In that case, prev_input contains only nulls and we skip the if body. + if (token_ptr[3] >= 0x80u) { + // Look for an incomplete multi-byte code point + if (token_ptr[3] >= 0xC0u) { + rollback = 1; + } else if (token_ptr[2] >= 0xE0u) { + rollback = 2; + } else if (token_ptr[1] >= 0xF0u) { + rollback = 3; + } + } + // Finish the job. + uint8_t const *const small_ptr = ptr - rollback; + size_t const small_len = remaining + rollback; + return is_valid_utf8_fallback(small_ptr, small_len); +} + +#endif + +#if defined(__x86_64__) && !defined(CRUFTY_GCC) +static inline bool has_sse2() { + uint32_t eax = 0, ebx = 0, ecx = 0, edx = 0; + __get_cpuid_count(1, 0, &eax, &ebx, &ecx, &edx); + // https://en.wikipedia.org/wiki/CPUID#EAX=1:_Processor_Info_and_Feature_Bits + return edx & (1 << 26); +} + +static inline bool has_ssse3() { + uint32_t eax = 0, ebx = 0, ecx = 0, edx = 0; + __get_cpuid_count(1, 0, &eax, &ebx, &ecx, &edx); + // https://en.wikipedia.org/wiki/CPUID#EAX=1:_Processor_Info_and_Feature_Bits + return ecx & (1 << 9); +} + +static inline bool has_avx2() { + uint32_t eax = 0, ebx = 0, ecx = 0, edx = 0; + __get_cpuid_count(7, 0, &eax, &ebx, &ecx, &edx); + // https://en.wikipedia.org/wiki/CPUID#EAX=7,_ECX=0:_Extended_Features + return ebx & (1 << 5); +} +#endif + +typedef int (*is_valid_utf8_t)(uint8_t const *const, size_t const); + +int bytestring_is_valid_utf8(uint8_t const *const src, size_t const len) { + if (len == 0) { + return 1; + } +#if defined(__x86_64__) && !defined(CRUFTY_GCC) + static _Atomic is_valid_utf8_t s_impl = (is_valid_utf8_t)NULL; + is_valid_utf8_t impl = atomic_load_explicit(&s_impl, memory_order_relaxed); + if (!impl) { + impl = has_avx2() ? is_valid_utf8_avx2 + : (has_ssse3() ? is_valid_utf8_ssse3 + : (has_sse2() ? is_valid_utf8_sse2 + : is_valid_utf8_fallback)); + atomic_store_explicit(&s_impl, impl, memory_order_relaxed); + } + return (*impl)(src, len); +#else + return is_valid_utf8_fallback(src, len); +#endif +} + +#pragma GCC pop_options diff --git a/cbits/shortbytestring.c b/cbits/shortbytestring.c new file mode 100644 --- /dev/null +++ b/cbits/shortbytestring.c @@ -0,0 +1,21 @@ +#include +#include +#include +#include + + +ptrdiff_t +sbs_elem_index(const void *s, + uint8_t c, + size_t n) +{ + const void *so = memchr(s, c, n); + + if (so) { + ptrdiff_t diff = so - s; + assert(diff >= 0); + return diff; + } else { + return -1; + } +} diff --git a/include/bytestring-cpp-macros.h b/include/bytestring-cpp-macros.h new file mode 100644 --- /dev/null +++ b/include/bytestring-cpp-macros.h @@ -0,0 +1,50 @@ +#if defined(__STDC__) || defined(__GNUC__) || defined(__clang__) +#error "bytestring-cpp-macros.h does not work in C code yet" +#endif + + +#if defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH) \ + || ((defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)) \ + && defined(__ARM_FEATURE_UNALIGNED)) \ + || defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH) \ + || defined(powerpc64le_HOST_ARCH) \ + || defined(javascript_HOST_ARCH) +/* +Not all architectures are forgiving of unaligned accesses; whitelist ones +which are known not to trap (either to the kernel for emulation, or crash). +*/ +#define HS_UNALIGNED_POKES_OK 1 +#else +#if PURE_HASKELL +#error "-fpure-haskell isn't supported yet on architectures only supporting aligned accesses." +#endif +#define HS_UNALIGNED_POKES_OK 0 +#endif + + +#define HS_UNALIGNED_ByteArray_OPS_OK \ + MIN_VERSION_base(4,12,0) \ + && (MIN_VERSION_base(4,16,1) || HS_UNALIGNED_POKES_OK) +/* +The unaligned ByteArray# primops became available with base-4.12.0/ghc-8.6, +but require an unaligned-friendly host architecture to be safe to use +until ghc-9.2.2; see https://gitlab.haskell.org/ghc/ghc/-/issues/21015 +*/ + + +#define HS_CAST_FLOAT_WORD_OPS_AVAILABLE MIN_VERSION_base(4,14,0) +/* +These operations were added in base-4.10.0, but due to +https://gitlab.haskell.org/ghc/ghc/-/issues/16617 they +are buggy with negative floats before ghc-8.10. +*/ + +#define HS_UNALIGNED_ADDR_PRIMOPS_AVAILABLE MIN_VERSION_base(4,20,0) + +#define HS_timesInt2_PRIMOP_AVAILABLE MIN_VERSION_base(4,15,0) + +#define HS_cstringLength_AND_FinalPtr_AVAILABLE MIN_VERSION_base(4,15,0) + /* These two were added in the same ghc commit and + both primarily affect how we handle literals */ + +#define HS_unsafeWithForeignPtr_AVAILABLE MIN_VERSION_base(4,15,0) diff --git a/tests/Builder.hs b/tests/Builder.hs new file mode 100644 --- /dev/null +++ b/tests/Builder.hs @@ -0,0 +1,14 @@ +module Builder (testSuite) where + +import qualified Data.ByteString.Builder.Tests +import qualified Data.ByteString.Builder.Prim.Tests +import Test.Tasty (TestTree, testGroup) + +testSuite :: TestTree +testSuite = testGroup "Builder" + [ testGroup "Data.ByteString.Builder" + Data.ByteString.Builder.Tests.tests + + , testGroup "Data.ByteString.Builder.BasicEncoding" + Data.ByteString.Builder.Prim.Tests.tests + ] diff --git a/tests/IsValidUtf8.hs b/tests/IsValidUtf8.hs new file mode 100644 --- /dev/null +++ b/tests/IsValidUtf8.hs @@ -0,0 +1,364 @@ +module IsValidUtf8 (testSuite) where + +import Data.Bits (shiftR, (.&.), shiftL) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Short as SBS +import qualified Data.ByteString as B +import Data.Char (chr, ord) +import Data.Word (Word8) +import Control.Monad (guard) +import Numeric (showHex) +import GHC.Exts (fromList, fromListN, toList) +import Test.QuickCheck (Property, forAll, (===), forAllShrinkShow) +import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary, shrink)) +import Test.QuickCheck.Gen (oneof, Gen, choose, vectorOf, listOf1, sized, resize, + elements, choose) +import Test.Tasty (testGroup, adjustOption, TestTree) +import Test.Tasty.QuickCheck (testProperty, QuickCheckTests) + +testSuite :: TestTree +testSuite = testGroup "UTF-8 validation" [ + adjustOption (max testCount) . testProperty "Valid UTF-8 ByteString" $ goValidBS, + adjustOption (max testCount) . testProperty "Invalid UTF-8 ByteString" $ goInvalidBS, + adjustOption (max testCount) . testProperty "Valid UTF-8 ShortByteString" $ goValidSBS, + adjustOption (max testCount) . testProperty "Invalid UTF-8 ShortByteString" $ goInvalidSBS, + testGroup "Regressions" checkRegressions + ] + where + goValidBS :: ValidUtf8 -> Bool + goValidBS = B.isValidUtf8 . foldMap sequenceToBS . unValidUtf8 + goInvalidBS :: InvalidUtf8 -> Bool + goInvalidBS = not . B.isValidUtf8 . toByteString + goValidSBS :: ValidUtf8 -> Bool + goValidSBS = SBS.isValidUtf8 . SBS.toShort . foldMap sequenceToBS . unValidUtf8 + goInvalidSBS :: InvalidUtf8 -> Bool + goInvalidSBS = not . SBS.isValidUtf8 . SBS.toShort . toByteString + testCount :: QuickCheckTests + testCount = 1000 + +checkRegressions :: [TestTree] +checkRegressions = [ + testProperty "Too high code point" $ + not $ B.isValidUtf8 tooHigh, + testProperty "Invalid byte at end of ASCII block" badBlockEnd, + testProperty "Invalid byte between spaces" $ + not $ B.isValidUtf8 byteBetweenSpaces, + testProperty "Two invalid bytes between spaces" $ + not $ B.isValidUtf8 twoBytesBetweenSpaces, + testProperty "Three invalid bytes between spaces" $ + not $ B.isValidUtf8 threeBytesBetweenSpaces, + testProperty "ASCII stride and invalid multibyte sequence" $ + not $ B.isValidUtf8 asciiAndInvalidMultiByte, + testProperty "Splitting valid in two" splitValid + ] + where + tooHigh :: ByteString + tooHigh = fromList $ replicate 56 48 ++ -- 56 ASCII zeroes + [244, 176, 181, 139] ++ -- our invalid sequence too high to be valid + (take 68 . cycle $ [194, 162]) -- 68 cent symbols + + byteBetweenSpaces :: ByteString + byteBetweenSpaces = fromList $ replicate 127 32 ++ [216] ++ replicate 128 32 + + twoBytesBetweenSpaces :: ByteString + twoBytesBetweenSpaces = fromList $ replicate 126 32 ++ [235, 167] ++ replicate 128 32 + + threeBytesBetweenSpaces :: ByteString + threeBytesBetweenSpaces = fromList $ replicate 125 32 ++ [242, 134, 159] ++ replicate 128 32 + + badBlockEnd :: Property + badBlockEnd = + forAllShrinkShow genBadBlock shrinkBadBlock showBadBlock $ \(BadBlock bs) -> + not . B.isValidUtf8 $ bs + + asciiAndInvalidMultiByte :: ByteString + asciiAndInvalidMultiByte = fromList $ replicate 32 48 ++ [235, 185] + + splitValid :: Property + splitValid = forAll genValidUtf8 $ \bs -> + forAll (choose (0, B.length bs)) $ \k -> + case B.splitAt k bs of + -- q may have non-zero offset, which + -- allows this property test to tickle #620 + (p, q) -> B.isValidUtf8 p == B.isValidUtf8 q + +-- Helpers + +-- A 128-byte sequence with a single bad byte at the end, with the rest being +-- ASCII +newtype BadBlock = BadBlock ByteString + +genBadBlock :: Gen BadBlock +genBadBlock = do + asciiBytes <- vectorOf 127 $ choose (0, 127) + pure . BadBlock . fromListN 128 $ asciiBytes ++ [216] + +shrinkBadBlock :: BadBlock -> [BadBlock] +shrinkBadBlock (BadBlock bs) = BadBlock <$> do + let asList = init . toList $ bs + init' <- fromList <$> traverse shrink asList + guard (B.length init' == 127) + pure . B.append init' . B.singleton $ 216 + +-- Display as hex instead of ASCII-ish +showBadBlock :: BadBlock -> String +showBadBlock (BadBlock bs) = let asList = toList bs in + foldr showHex "" asList + +data Utf8Sequence = + One Word8 | + Two Word8 Word8 | + Three Word8 Word8 Word8 | + Four Word8 Word8 Word8 Word8 + deriving (Eq) + +instance Arbitrary Utf8Sequence where + arbitrary = oneof [ + One <$> elements [0x00 .. 0x7F], + Two <$> elements [0xC2 .. 0xDF] <*> elements [0x80 .. 0xBF], + genThree, + genFour + ] + where + genThree :: Gen Utf8Sequence + genThree = do + w1 <- elements [0xE0 .. 0xED] + w2 <- elements $ case w1 of + 0xE0 -> [0xA0 .. 0xBF] + 0xED -> [0x80 .. 0x9F] + _ -> [0x80 .. 0xBF] + w3 <- elements [0x80 .. 0xBF] + pure . Three w1 w2 $ w3 + genFour :: Gen Utf8Sequence + genFour = do + w1 <- elements [0xF0 .. 0xF4] + w2 <- elements $ case w1 of + 0xF0 -> [0x90 .. 0xBF] + 0xF4 -> [0x80 .. 0x8F] + _ -> [0x80 .. 0xBF] + w3 <- elements [0x80 .. 0xBF] + w4 <- elements [0x80 .. 0xBF] + pure . Four w1 w2 w3 $ w4 + shrink = \case + One w1 -> One <$> case w1 of + 0x00 -> [] + _ -> [0x00 .. (w1 - 1)] + Two w1 w2 -> case (w1, w2) of + (0xC2, 0x80) -> allOnes + _ -> (Two <$> [0xC2 .. (w1 - 1)] <*> [0x80 .. (w2 - 1)]) ++ allOnes + Three w1 w2 w3 -> case (w1, w2, w3) of + (0xE0, 0xA0, 0x80) -> allTwos ++ allOnes + (0xE0, 0xA0, _) -> (Three 0xE0 0xA0 <$> [0x80 .. (w3 - 1)]) ++ allTwos ++ allOnes + (0xE0, _, _) -> + (Three 0xE0 <$> [0xA0 .. (w2 - 1)] <*> [0x80 .. (w3 - 1)]) ++ allTwos ++ allOnes + _ -> do + w1' <- [0xE0 .. (w1 - 1)] + case w1' of + 0xE0 -> (Three 0xE0 <$> [0xA0 .. 0xBF] <*> [0x80 .. 0xBF]) ++ + allTwos ++ + allOnes + _ -> (Three w1' <$> [0x80 .. 0xBF] <*> [0x80 .. 0xBF]) ++ + allTwos ++ + allOnes + Four w1 w2 w3 w4 -> case (w1, w2, w3, w4) of + (0xF0, 0x90, 0x80, 0x80) -> allThrees ++ allTwos ++ allOnes + (0xF0, 0x90, 0x80, _) -> + (Four 0xF0 0x90 0x80 <$> [0x80 .. (w4 - 1)]) ++ + allThrees ++ + allTwos ++ + allOnes + (0xF0, 0x90, _, _) -> + (Four 0xF0 0x90 <$> [0x80 .. (w3 - 1)] <*> [0x80 .. (w4 - 1)]) ++ + allThrees ++ + allTwos ++ + allOnes + (0xF0, _, _, _) -> + (Four 0xF0 <$> [0x90 .. (w2 - 1)] <*> [0x80 .. (w3 - 1)] <*> [0x80 .. (w4 - 1)]) ++ + allThrees ++ + allTwos ++ + allOnes + _ -> do + w1' <- [0xF0 .. (w1 - 1)] + case w1' of + 0xF0 -> (Four 0xF0 <$> [0x90 .. 0xBF] <*> [0x80 .. 0xBF] <*> [0x80 .. 0xBF]) ++ + allThrees ++ + allTwos ++ + allOnes + _ -> (Four w1' <$> [0x80 .. 0xBF] <*> [0x80 .. 0xBF] <*> [0x80 .. 0xBF]) ++ + allThrees ++ + allTwos ++ + allOnes + +allOnes :: [Utf8Sequence] +allOnes = One <$> [0x00 .. 0x7F] + +allTwos :: [Utf8Sequence] +allTwos = Two <$> [0xC2 .. 0xDF] <*> [0x80 .. 0xBF] + +allThrees :: [Utf8Sequence] +allThrees = (Three 0xE0 <$> [0xA0 .. 0xBF] <*> [0x80 .. 0xBF]) ++ + (Three 0xED <$> [0x80 .. 0x9F] <*> [0x80 .. 0xBF]) ++ + (Three <$> [0xE1 .. 0xEC] <*> [0x80 .. 0xBF] <*> [0x80 .. 0xBF]) ++ + (Three <$> [0xEE .. 0xEF] <*> [0x80 .. 0xBF] <*> [0x80 .. 0xBF]) + +sequenceToBS :: Utf8Sequence -> ByteString +sequenceToBS = B.pack . \case + One w1 -> [w1] + Two w1 w2 -> [w1, w2] + Three w1 w2 w3 -> [w1, w2, w3] + Four w1 w2 w3 w4 -> [w1, w2, w3, w4] + +newtype ValidUtf8 = ValidUtf8 { unValidUtf8 :: [Utf8Sequence] } + deriving (Eq) + +instance Show ValidUtf8 where + show (ValidUtf8 ss) = show . foldMap sequenceToBS $ ss + +instance Arbitrary ValidUtf8 where + arbitrary = ValidUtf8 <$> arbitrary + shrink (ValidUtf8 ss) = ValidUtf8 <$> shrink ss + +data InvalidUtf8 = InvalidUtf8 { + prefix :: ByteString, + invalid :: ByteString, + suffix :: ByteString + } + deriving (Eq) + +instance Show InvalidUtf8 where + show i = "InvalidUtf8 {prefix = " ++ show (prefix i) + ++ ", invalid = " ++ show (invalid i) + ++ ", suffix = " ++ show (suffix i) + ++ ", asBS = " ++ show (toByteString i) + ++ ", length = " ++ show (B.length . toByteString $ i) + ++ "}" + +instance Arbitrary InvalidUtf8 where + arbitrary = oneof + [ InvalidUtf8 mempty <$> genInvalidUtf8 <*> pure mempty + , InvalidUtf8 mempty <$> genInvalidUtf8 <*> genValidUtf8 + , InvalidUtf8 <$> genValidUtf8 <*> genInvalidUtf8 <*> pure mempty + , InvalidUtf8 <$> genValidUtf8 <*> genInvalidUtf8 <*> genValidUtf8 + ] + shrink (InvalidUtf8 p i s) = + (InvalidUtf8 p i <$> shrinkValidBS s) ++ + ((\p' -> InvalidUtf8 p' i s) <$> shrinkValidBS p) + +toByteString :: InvalidUtf8 -> ByteString +toByteString (InvalidUtf8 p i s) = p `B.append` i `B.append` s + +genInvalidUtf8 :: Gen ByteString +genInvalidUtf8 = B.pack <$> oneof [ + -- invalid leading byte of a 2-byte sequence + (:) <$> choose (0xC0, 0xC1) <*> upTo 1 contByte + -- invalid leading byte of a 4-byte sequence + , (:) <$> choose (0xF5, 0xFF) <*> upTo 3 contByte + -- 4-byte sequence greater than U+10FFF + , do k <- choose (0x11, 0x13) + let w0 = 0xF0 + (k `shiftR` 2) + let w1 = 0x80 + ((k .&. 3) `shiftL` 4) + ([w0, w1] ++) <$> vectorOf 2 contByte + -- continuation bytes without a start byte + , listOf1 contByte + -- short 2-byte sequence + , (:[]) <$> choose (0xC2, 0xDF) + -- short 3-byte sequence + , (:) <$> choose (0xE0, 0xEF) <*> upTo 1 contByte + -- short 4-byte sequence + , (:) <$> choose (0xF0, 0xF4) <*> upTo 2 contByte + -- overlong encoding + , do k <- choose (0, 0xFFFF) + let c = chr k + case k of + _ | k < 0x80 -> oneof [ let (w, x) = ord2 c in pure [w, x] + , let (w, x, y) = ord3 c in pure [w, x, y] + , let (w, x, y, z) = ord4 c in pure [w, x, y, z] ] + | k < 0x7FF -> oneof [ let (w, x, y) = ord3 c in pure [w, x, y] + , let (w, x, y, z) = ord4 c in pure [w, x, y, z] ] + | otherwise -> oneof [ let (w, x, y, z) = ord4 c in pure [w, x, y, z] ] + ] + where + contByte :: Gen Word8 + contByte = (0x80 +) <$> choose (0, 0x3F) + upTo :: Int -> Gen a -> Gen [a] + upTo n gen = do + k <- choose (0, n) + vectorOf k gen + +genValidUtf8 :: Gen ByteString +genValidUtf8 = sized $ \size -> + if size <= 0 + then pure mempty + else oneof [ + B.append <$> genAscii <*> resize (size `div` 2) genValidUtf8, + B.append <$> gen2Byte <*> resize (size `div` 2) genValidUtf8, + B.append <$> gen3Byte <*> resize (size `div` 2) genValidUtf8, + B.append <$> gen4Byte <*> resize (size `div` 2) genValidUtf8, + B.replicate <$> resize (size * 16) arbitrary <*> elements [0x00 .. 0x7F] + ] + where + genAscii :: Gen ByteString + genAscii = B.pack . (:[]) <$> elements [0x00 .. 0x7F] + gen2Byte :: Gen ByteString + gen2Byte = do + b1 <- elements [0xC2 .. 0xDF] + b2 <- elements [0x80 .. 0xBF] + pure . B.pack $ [b1, b2] + gen3Byte :: Gen ByteString + gen3Byte = do + b1 <- elements [0xE0 .. 0xED] + b2 <- elements $ case b1 of + 0xE0 -> [0xA0 .. 0xBF] + 0xED -> [0x80 .. 0x9F] + _ -> [0x80 .. 0xBF] + b3 <- elements [0x80 .. 0xBF] + pure . B.pack $ [b1, b2, b3] + gen4Byte :: Gen ByteString + gen4Byte = do + b1 <- elements [0xF0 .. 0xF4] + b2 <- elements $ case b1 of + 0xF0 -> [0x90 .. 0xBF] + 0xF4 -> [0x80 .. 0x8F] + _ -> [0x80 .. 0xBF] + b3 <- elements [0x80 .. 0xBF] + b4 <- elements [0x80 .. 0xBF] + pure . B.pack $ [b1, b2, b3, b4] + +shrinkValidBS :: ByteString -> [ByteString] +shrinkValidBS bs = filter B.isValidUtf8 (map B.pack (shrink (B.unpack bs))) + +ord2 :: Char -> (Word8, Word8) +ord2 c = (x, y) + where + n :: Int + n = ord c + x :: Word8 + x = fromIntegral $ (n `shiftR` 6) + 0xC0 + y :: Word8 + y = fromIntegral $ (n .&. 0x3F) + 0x80 + +ord3 :: Char -> (Word8, Word8, Word8) +ord3 c = (x, y, z) + where + n :: Int + n = ord c + x :: Word8 + x = fromIntegral $ (n `shiftR` 12) + 0xE0 + y :: Word8 + y = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + z :: Word8 + z = fromIntegral $ (n .&. 0x3F) + 0x80 + +ord4 :: Char -> (Word8, Word8, Word8, Word8) +ord4 c = (x, y, z, a) + where + n :: Int + n = ord c + x :: Word8 + x = fromIntegral $ (n `shiftR` 18) + 0xF0 + y :: Word8 + y = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80 + z :: Word8 + z = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + a :: Word8 + a = fromIntegral $ (n .&. 0x3F) + 0x80 diff --git a/tests/LazyHClose.hs b/tests/LazyHClose.hs --- a/tests/LazyHClose.hs +++ b/tests/LazyHClose.hs @@ -1,4 +1,4 @@ -module Main (main) where +module LazyHClose (testSuite) where import Control.Monad (void, forM_) import Data.ByteString.Internal (toForeignPtr) @@ -6,59 +6,59 @@ 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 -main :: IO () -main = do - let n = 1000 - (fn, h) <- openTempFile "." "lazy-hclose-test.tmp" - hPutStrLn h "x" - hClose h - - ------------------------------------------------------------------------ - -- readFile tests - - putStrLn "Testing resource leaks for Strict.readFile" - forM_ [1..n] $ const $ do - r <- S.readFile fn - appendFile fn "" -- will fail, if fn has not been closed yet - - putStrLn "Testing resource leaks for Lazy.readFile" - forM_ [1..n] $ const $ do - r <- L.readFile fn - L.length r `seq` return () - appendFile fn "" -- will fail, if fn has not been closed yet +n :: Int +n = 1000 - -- manage the resources explicitly. - putStrLn "Testing resource leaks when converting lazy to strict" - forM_ [1..n] $ const $ do - 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 +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 - ------------------------------------------------------------------------ - -- hGetContents tests + , 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 - putStrLn "Testing strict hGetContents" - forM_ [1..n] $ const $ do - 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 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 - putStrLn "Testing lazy hGetContents" - forM_ [1..n] $ const $ do - h <- openFile fn ReadMode - r <- L.hGetContents h - L.last r `seq` return () - 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 - removeFile fn + , testProperty "Testing lazy hGetContents" $ ioProperty $ + forM_ [1..n] $ const $ do + fn <- fn' + h <- openFile fn ReadMode + r <- L.hGetContents h + L.last r `seq` return () + appendFile fn "" -- will fail, if fn has not been closed yet + ] removeFile :: String -> IO () removeFile fn = void $ withCString fn c_unlink diff --git a/tests/Lift.hs b/tests/Lift.hs new file mode 100644 --- /dev/null +++ b/tests/Lift.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE CPP #-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Lift (testSuite) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty, (===)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Short as SBS +import qualified Language.Haskell.TH.Syntax as TH + +testSuite :: TestTree +#ifdef wasm32_HOST_ARCH +testSuite = testGroup "Skipped, requires -fexternal-interpreter" [] +#else +testSuite = testGroup "Lift" + [ testGroup "strict" + [ testProperty "normal" $ + let bs = "foobar" :: BS.ByteString in + bs === $(TH.lift $ BS.pack [102,111,111,98,97,114]) + + , testProperty "binary" $ + let bs = "\0\1\2\3\0\1\2\3" :: BS.ByteString in + bs === $(TH.lift $ BS.pack [0,1,2,3,0,1,2,3]) + +#if MIN_VERSION_template_haskell(2,16,0) + , testProperty "typed" $ + let bs = "\0\1\2\3\0\1\2\3" :: BS.ByteString in + bs === $$(TH.liftTyped $ BS.pack [0,1,2,3,0,1,2,3]) +#endif + ] + + , testGroup "lazy" + [ testProperty "normal" $ + let bs = "foobar" :: LBS.ByteString in + bs === $(TH.lift $ LBS.pack [102,111,111,98,97,114]) + + , testProperty "binary" $ + let bs = "\0\1\2\3\0\1\2\3" :: LBS.ByteString in + bs === $(TH.lift $ LBS.pack [0,1,2,3,0,1,2,3]) + +#if MIN_VERSION_template_haskell(2,16,0) + , testProperty "typed" $ + let bs = "\0\1\2\3\0\1\2\3" :: LBS.ByteString in + bs === $$(TH.liftTyped $ LBS.pack [0,1,2,3,0,1,2,3]) +#endif + ] + + , testGroup "short" + [ testProperty "normal" $ + let bs = "foobar" :: SBS.ShortByteString in + bs === $(TH.lift $ SBS.pack [102,111,111,98,97,114]) + + , testProperty "binary" $ + let bs = "\0\1\2\3\0\1\2\3" :: SBS.ShortByteString in + bs === $(TH.lift $ SBS.pack [0,1,2,3,0,1,2,3]) + +#if MIN_VERSION_template_haskell(2,16,0) + , testProperty "typed" $ + let bs = "\0\1\2\3\0\1\2\3" :: SBS.ShortByteString in + bs === $$(TH.liftTyped $ SBS.pack [0,1,2,3,0,1,2,3]) +#endif + ] + ] +#endif diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,18 @@ +module Main (main) where + +import Test.Tasty + +import qualified Builder +import qualified IsValidUtf8 +import qualified LazyHClose +import qualified Lift +import qualified Properties + +main :: IO () +main = defaultMain $ testGroup "All" + [ Builder.testSuite + , IsValidUtf8.testSuite + , LazyHClose.testSuite + , Lift.testSuite + , Properties.testSuite + ] diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -1,2556 +1,750 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} --- --- Must have rules off, otherwise the rewrite rules will replace the rhs --- with the lhs, and we only end up testing lhs == lhs --- - --- --- -fhpc interferes with rewrite rules firing. --- - -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 Data.List -import Data.Char -import Data.Word -import Data.Maybe -import Data.Int (Int64) -import Data.Monoid -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup -#endif -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 Prelude hiding (abs) - -import Rules -import QuickCheckUtils -import Test.Tasty -import Test.Tasty.QuickCheck - -toInt64 :: Int -> Int64 -toInt64 = fromIntegral - --- --- ByteString.Lazy.Char8 <=> ByteString.Char8 --- - -prop_concatCC = D.concat `eq1` C.concat -prop_nullCC = D.null `eq1` C.null -prop_reverseCC = D.reverse `eq1` C.reverse -prop_transposeCC = D.transpose `eq1` C.transpose -prop_groupCC = D.group `eq1` C.group -prop_groupByCC = D.groupBy `eq2` C.groupBy -prop_initsCC = D.inits `eq1` C.inits -prop_tailsCC = D.tails `eq1` C.tails -prop_allCC = D.all `eq2` C.all -prop_anyCC = D.any `eq2` C.any -prop_appendCC = D.append `eq2` C.append -prop_breakCC = D.break `eq2` C.break -prop_concatMapCC = forAll (sized $ \n -> resize (min 50 n) arbitrary) $ - D.concatMap `eq2` C.concatMap -prop_consCC = D.cons `eq2` C.cons -prop_consCC' = D.cons' `eq2` C.cons -prop_unconsCC = D.uncons `eq1` C.uncons -prop_unsnocCC = D.unsnoc `eq1` C.unsnoc -prop_countCC = D.count `eq2` ((toInt64 .) . C.count) -prop_dropCC = (D.drop . toInt64) `eq2` C.drop -prop_dropWhileCC = D.dropWhile `eq2` C.dropWhile -prop_filterCC = D.filter `eq2` C.filter -prop_findCC = D.find `eq2` C.find -prop_findIndexCC = D.findIndex `eq2` ((fmap toInt64 .) . C.findIndex) -prop_findIndexEndCC = D.findIndexEnd `eq2` ((fmap toInt64 .) . C.findIndexEnd) -prop_findIndicesCC = D.findIndices `eq2` ((fmap toInt64 .) . C.findIndices) -prop_isPrefixOfCC = D.isPrefixOf `eq2` C.isPrefixOf -prop_stripPrefixCC = D.stripPrefix `eq2` C.stripPrefix -prop_isSuffixOfCC = D.isSuffixOf `eq2` C.isSuffixOf -prop_stripSuffixCC = D.stripSuffix `eq2` C.stripSuffix -prop_mapCC = D.map `eq2` C.map -prop_replicateCC = forAll arbitrarySizedIntegral $ - (D.replicate . toInt64) `eq2` C.replicate -prop_snocCC = D.snoc `eq2` C.snoc -prop_spanCC = D.span `eq2` C.span -prop_splitCC = D.split `eq2` C.split -prop_splitAtCC = (D.splitAt . toInt64) `eq2` C.splitAt -prop_takeCC = (D.take . toInt64) `eq2` C.take -prop_takeWhileCC = D.takeWhile `eq2` C.takeWhile -prop_elemCC = D.elem `eq2` C.elem -prop_notElemCC = D.notElem `eq2` C.notElem -prop_elemIndexCC = D.elemIndex `eq2` ((fmap toInt64 .) . C.elemIndex) -prop_elemIndicesCC = D.elemIndices `eq2` ((fmap toInt64 .) . C.elemIndices) -prop_lengthCC = D.length `eq1` (toInt64 . C.length) - -prop_headCC = D.head `eqnotnull1` C.head -prop_initCC = D.init `eqnotnull1` C.init -prop_lastCC = D.last `eqnotnull1` C.last -prop_maximumCC = D.maximum `eqnotnull1` C.maximum -prop_minimumCC = D.minimum `eqnotnull1` C.minimum -prop_tailCC = D.tail `eqnotnull1` C.tail -prop_foldl1CC = D.foldl1 `eqnotnull2` C.foldl1 -prop_foldl1CC' = D.foldl1' `eqnotnull2` C.foldl1' -prop_foldr1CC = D.foldr1 `eqnotnull2` C.foldr1 -prop_foldr1CC' = D.foldr1 `eqnotnull2` C.foldr1' -prop_scanlCC = D.scanl `eqnotnull3` C.scanl - -prop_intersperseCC = D.intersperse `eq2` C.intersperse - -prop_foldlCC = eq3 - (D.foldl :: (X -> Char -> X) -> X -> B -> X) - (C.foldl :: (X -> Char -> X) -> X -> P -> X) -prop_foldlCC' = eq3 - (D.foldl' :: (X -> Char -> X) -> X -> B -> X) - (C.foldl' :: (X -> Char -> X) -> X -> P -> X) -prop_foldrCC = eq3 - (D.foldr :: (Char -> X -> X) -> X -> B -> X) - (C.foldr :: (Char -> X -> X) -> X -> P -> X) -prop_foldrCC' = eq3 - (D.foldr :: (Char -> X -> X) -> X -> B -> X) - (C.foldr' :: (Char -> X -> X) -> X -> P -> X) -prop_mapAccumLCC = eq3 - (D.mapAccumL :: (X -> Char -> (X,Char)) -> X -> B -> (X, B)) - (C.mapAccumL :: (X -> Char -> (X,Char)) -> X -> P -> (X, P)) - ---prop_mapIndexedCC = D.mapIndexed `eq2` C.mapIndexed ---prop_mapIndexedPL = L.mapIndexed `eq2` P.mapIndexed - ---prop_mapAccumL_mapIndexedBP = --- P.mapIndexed `eq2` --- (\k p -> snd $ P.mapAccumL (\i w -> (i+1, k i w)) (0::Int) p) - --- --- ByteString.Lazy <=> ByteString --- - -prop_concatBP = forAll (sized $ \n -> resize (n `div` 2) arbitrary) $ - L.concat `eq1` P.concat -prop_nullBP = L.null `eq1` P.null -prop_reverseBP = L.reverse `eq1` P.reverse - -prop_transposeBP = L.transpose `eq1` P.transpose -prop_groupBP = L.group `eq1` P.group -prop_groupByBP = L.groupBy `eq2` P.groupBy -prop_initsBP = L.inits `eq1` P.inits -prop_tailsBP = L.tails `eq1` P.tails -prop_allBP = L.all `eq2` P.all -prop_anyBP = L.any `eq2` P.any -prop_appendBP = L.append `eq2` P.append -prop_breakBP = L.break `eq2` P.break -prop_concatMapBP = forAll (sized $ \n -> resize (n `div` 4) arbitrary) $ - L.concatMap `eq2` P.concatMap -prop_consBP = L.cons `eq2` P.cons -prop_consBP' = L.cons' `eq2` P.cons -prop_unconsBP = L.uncons `eq1` P.uncons -prop_unsnocBP = L.unsnoc `eq1` P.unsnoc -prop_countBP = L.count `eq2` ((toInt64 .) . P.count) -prop_dropBP = (L.drop. toInt64) `eq2` P.drop -prop_dropWhileBP = L.dropWhile `eq2` P.dropWhile -prop_filterBP = L.filter `eq2` P.filter -prop_findBP = L.find `eq2` P.find -prop_findIndexBP = L.findIndex `eq2` ((fmap toInt64 .) . P.findIndex) -prop_findIndexEndBP = L.findIndexEnd `eq2` ((fmap toInt64 .) . P.findIndexEnd) -prop_findIndicesBP = L.findIndices `eq2` ((fmap toInt64 .) . P.findIndices) -prop_isPrefixOfBP = L.isPrefixOf `eq2` P.isPrefixOf -prop_stripPrefixBP = L.stripPrefix `eq2` P.stripPrefix -prop_isSuffixOfBP = L.isSuffixOf `eq2` P.isSuffixOf -prop_stripSuffixBP = L.stripSuffix `eq2` P.stripSuffix -prop_mapBP = L.map `eq2` P.map -prop_replicateBP = forAll arbitrarySizedIntegral $ - (L.replicate. toInt64) `eq2` P.replicate -prop_snocBP = L.snoc `eq2` P.snoc -prop_spanBP = L.span `eq2` P.span -prop_splitBP = L.split `eq2` P.split -prop_splitAtBP = (L.splitAt. toInt64) `eq2` P.splitAt -prop_takeBP = (L.take . toInt64) `eq2` P.take -prop_takeWhileBP = L.takeWhile `eq2` P.takeWhile -prop_elemBP = L.elem `eq2` P.elem -prop_notElemBP = L.notElem `eq2` P.notElem -prop_elemIndexBP = L.elemIndex `eq2` ((fmap toInt64 .) . P.elemIndex) -prop_elemIndexEndBP = L.elemIndexEnd `eq2` ((fmap toInt64 .) . P.elemIndexEnd) -prop_elemIndicesBP = L.elemIndices `eq2` ((fmap toInt64 .) . P.elemIndices) -prop_intersperseBP = L.intersperse `eq2` P.intersperse -prop_lengthBP = L.length `eq1` (toInt64 . P.length) -prop_readIntBP = D.readInt `eq1` C.readInt -prop_linesBP = D.lines `eq1` C.lines - --- double check: --- Currently there's a bug in the lazy bytestring version of lines, this --- catches it: -prop_linesNLBP = eq1 D.lines C.lines x - where x = D.pack "one\ntwo\n\n\nfive\n\nseven\n" - -prop_headBP = L.head `eqnotnull1` P.head -prop_initBP = L.init `eqnotnull1` P.init -prop_lastBP = L.last `eqnotnull1` P.last -prop_maximumBP = L.maximum `eqnotnull1` P.maximum -prop_minimumBP = L.minimum `eqnotnull1` P.minimum -prop_tailBP = L.tail `eqnotnull1` P.tail -prop_foldl1BP = L.foldl1 `eqnotnull2` P.foldl1 -prop_foldl1BP' = L.foldl1' `eqnotnull2` P.foldl1' -prop_foldr1BP = L.foldr1 `eqnotnull2` P.foldr1 -prop_foldr1BP' = L.foldr1 `eqnotnull2` P.foldr1' -prop_scanlBP = L.scanl `eqnotnull3` P.scanl - - -prop_eqBP = eq2 - ((==) :: B -> B -> Bool) - ((==) :: P -> P -> Bool) -prop_compareBP = eq2 - ((compare) :: B -> B -> Ordering) - ((compare) :: P -> P -> Ordering) -prop_foldlBP = eq3 - (L.foldl :: (X -> W -> X) -> X -> B -> X) - (P.foldl :: (X -> W -> X) -> X -> P -> X) -prop_foldlBP' = eq3 - (L.foldl' :: (X -> W -> X) -> X -> B -> X) - (P.foldl' :: (X -> W -> X) -> X -> P -> X) -prop_foldrBP = eq3 - (L.foldr :: (W -> X -> X) -> X -> B -> X) - (P.foldr :: (W -> X -> X) -> X -> P -> X) -prop_foldrBP' = eq3 - (L.foldr :: (W -> X -> X) -> X -> B -> X) - (P.foldr' :: (W -> X -> X) -> X -> P -> X) -prop_mapAccumLBP = eq3 - (L.mapAccumL :: (X -> W -> (X,W)) -> X -> B -> (X, B)) - (P.mapAccumL :: (X -> W -> (X,W)) -> X -> P -> (X, P)) - -prop_unfoldrBP = - forAll arbitrarySizedIntegral $ - eq3 - ((\n f a -> L.take (fromIntegral n) $ - L.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> B) - ((\n f a -> fst $ - P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P) - -prop_unfoldr2BP = - forAll arbitrarySizedIntegral $ \n -> - forAll arbitrarySizedIntegral $ \a -> - eq2 - ((\n a -> P.take (n*100) $ - P.unfoldr (\x -> if x <= (n*100) then Just (fromIntegral x, x + 1) else Nothing) a) - :: Int -> Int -> P) - ((\n a -> fst $ - P.unfoldrN (n*100) (\x -> if x <= (n*100) then Just (fromIntegral x, x + 1) else Nothing) a) - :: Int -> Int -> P) - n a - -prop_unfoldr2CP = - forAll arbitrarySizedIntegral $ \n -> - forAll arbitrarySizedIntegral $ \a -> - eq2 - ((\n a -> C.take (n*100) $ - C.unfoldr (\x -> if x <= (n*100) then Just (chr (x `mod` 256), x + 1) else Nothing) a) - :: Int -> Int -> P) - ((\n a -> fst $ - C.unfoldrN (n*100) (\x -> if x <= (n*100) then Just (chr (x `mod` 256), x + 1) else Nothing) a) - :: Int -> Int -> P) - n a - - -prop_unfoldrLC = - forAll arbitrarySizedIntegral $ - eq3 - ((\n f a -> LC.take (fromIntegral n) $ - LC.unfoldr f a) :: Int -> (X -> Maybe (Char,X)) -> X -> B) - ((\n f a -> fst $ - C.unfoldrN n f a) :: Int -> (X -> Maybe (Char,X)) -> X -> P) - -prop_cycleLC a = - not (LC.null a) ==> - forAll arbitrarySizedIntegral $ - eq1 - ((\n -> LC.take (fromIntegral n) $ - LC.cycle a - ) :: Int -> B) - - ((\n -> LC.take (fromIntegral (n::Int)) . LC.concat $ - unfoldr (\x -> Just (x,x) ) a - ) :: Int -> B) - - -prop_iterateLC :: Int -> (Char8 -> Char8) -> Char8 -> Bool -prop_iterateLC n f (Char8 c) = - eq3 - (\n f a -> LC.take (fromIntegral n) $ LC.iterate f a) - (\n f a -> fst $ C.unfoldrN n (\a -> Just (f a, f a)) a) - n - (castFn f :: Char -> Char) - c - -prop_iterateLC_2 :: Int -> (Char8 -> Char8) -> Char8 -> Bool -prop_iterateLC_2 n f (Char8 c) = - eq3 - (\n f a -> LC.take (fromIntegral (n :: Int)) $ LC.iterate f a) - (\n f a -> LC.take (fromIntegral (n :: Int)) $ LC.unfoldr (\a -> Just (f a, f a)) a) - n - (castFn f :: Char -> Char) - c - -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 = forAll (sized $ \n -> resize (n `div` 2) arbitrary) $ - L.concat `eq1` (concat :: [[W]] -> [W]) -prop_lengthBL = L.length `eq1` (toInt64 . length :: [W] -> Int64) -prop_nullBL = L.null `eq1` (null :: [W] -> Bool) -prop_reverseBL = L.reverse `eq1` (reverse :: [W] -> [W]) -prop_transposeBL = L.transpose `eq1` (transpose :: [[W]] -> [[W]]) -prop_groupBL = L.group `eq1` (group :: [W] -> [[W]]) -prop_groupByBL = L.groupBy `eq2` (groupBy :: (W -> W -> Bool) -> [W] -> [[W]]) -prop_initsBL = L.inits `eq1` (inits :: [W] -> [[W]]) -prop_tailsBL = L.tails `eq1` (tails :: [W] -> [[W]]) -prop_allBL = L.all `eq2` (all :: (W -> Bool) -> [W] -> Bool) -prop_anyBL = L.any `eq2` (any :: (W -> Bool) -> [W] -> Bool) -prop_appendBL = L.append `eq2` ((++) :: [W] -> [W] -> [W]) -prop_breakBL = L.break `eq2` (break :: (W -> Bool) -> [W] -> ([W],[W])) -prop_concatMapBL = forAll (sized $ \n -> resize (n `div` 2) arbitrary) $ - L.concatMap `eq2` (concatMap :: (W -> [W]) -> [W] -> [W]) -prop_consBL = L.cons `eq2` ((:) :: W -> [W] -> [W]) -prop_dropBL = (L.drop . toInt64) `eq2` (drop :: Int -> [W] -> [W]) -prop_dropWhileBL = L.dropWhile `eq2` (dropWhile :: (W -> Bool) -> [W] -> [W]) -prop_filterBL = L.filter `eq2` (filter :: (W -> Bool ) -> [W] -> [W]) -prop_findBL = L.find `eq2` (find :: (W -> Bool) -> [W] -> Maybe W) -prop_findIndicesBL = L.findIndices `eq2` ((fmap toInt64 .) . findIndices:: (W -> Bool) -> [W] -> [Int64]) -prop_findIndexBL = L.findIndex `eq2` ((fmap toInt64 .) . findIndex :: (W -> Bool) -> [W] -> Maybe Int64) -prop_findIndexEndBL = L.findIndexEnd `eq2` ((fmap toInt64 .) . findIndexEnd :: (W -> Bool) -> [W] -> Maybe Int64) -prop_isPrefixOfBL = L.isPrefixOf `eq2` (isPrefixOf:: [W] -> [W] -> Bool) -prop_stripPrefixBL = L.stripPrefix `eq2` (stripPrefix:: [W] -> [W] -> Maybe [W]) -prop_isSuffixOfBL = L.isSuffixOf `eq2` (isSuffixOf:: [W] -> [W] -> Bool) -prop_stripSuffixBL = L.stripSuffix `eq2` (stripSuffix :: [W] -> [W] -> Maybe [W]) -prop_mapBL = L.map `eq2` (map :: (W -> W) -> [W] -> [W]) -prop_replicateBL = forAll arbitrarySizedIntegral $ - (L.replicate . toInt64) `eq2` (replicate :: Int -> W -> [W]) -prop_snocBL = L.snoc `eq2` ((\xs x -> xs ++ [x]) :: [W] -> W -> [W]) -prop_spanBL = L.span `eq2` (span :: (W -> Bool) -> [W] -> ([W],[W])) -prop_splitAtBL = (L.splitAt . toInt64) `eq2` (splitAt :: Int -> [W] -> ([W],[W])) -prop_takeBL = (L.take . toInt64) `eq2` (take :: Int -> [W] -> [W]) -prop_takeWhileBL = L.takeWhile `eq2` (takeWhile :: (W -> Bool) -> [W] -> [W]) -prop_elemBL = L.elem `eq2` (elem :: W -> [W] -> Bool) -prop_notElemBL = L.notElem `eq2` (notElem :: W -> [W] -> Bool) -prop_elemIndexBL = L.elemIndex `eq2` ((fmap toInt64 .) . elemIndex :: W -> [W] -> Maybe Int64) -prop_elemIndexEndBL = L.elemIndexEnd `eq2` ((fmap toInt64 .) . elemIndexEnd:: W -> [W] -> Maybe Int64) -prop_elemIndicesBL = L.elemIndices `eq2` ((fmap toInt64 .) . elemIndices :: W -> [W] -> [Int64]) -prop_linesBL = D.lines `eq1` (lines :: String -> [String]) - -prop_foldl1BL = L.foldl1 `eqnotnull2` (foldl1 :: (W -> W -> W) -> [W] -> W) -prop_foldl1BL' = L.foldl1' `eqnotnull2` (foldl1' :: (W -> W -> W) -> [W] -> W) -prop_foldr1BL = L.foldr1 `eqnotnull2` (foldr1 :: (W -> W -> W) -> [W] -> W) -prop_headBL = L.head `eqnotnull1` (head :: [W] -> W) -prop_initBL = L.init `eqnotnull1` (init :: [W] -> [W]) -prop_lastBL = L.last `eqnotnull1` (last :: [W] -> W) -prop_maximumBL = L.maximum `eqnotnull1` (maximum :: [W] -> W) -prop_minimumBL = L.minimum `eqnotnull1` (minimum :: [W] -> W) -prop_tailBL = L.tail `eqnotnull1` (tail :: [W] -> [W]) - -prop_eqBL = eq2 - ((==) :: B -> B -> Bool) - ((==) :: [W] -> [W] -> Bool) -prop_compareBL = eq2 - ((compare) :: B -> B -> Ordering) - ((compare) :: [W] -> [W] -> Ordering) -prop_foldlBL = eq3 - (L.foldl :: (X -> W -> X) -> X -> B -> X) - ( foldl :: (X -> W -> X) -> X -> [W] -> X) -prop_foldlBL' = eq3 - (L.foldl' :: (X -> W -> X) -> X -> B -> X) - ( foldl' :: (X -> W -> X) -> X -> [W] -> X) -prop_foldrBL = eq3 - (L.foldr :: (W -> X -> X) -> X -> B -> X) - ( foldr :: (W -> X -> X) -> X -> [W] -> X) -prop_mapAccumLBL = eq3 - (L.mapAccumL :: (X -> W -> (X,W)) -> X -> B -> (X, B)) - ( mapAccumL :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) - -prop_mapAccumRBL = eq3 - (L.mapAccumR :: (X -> W -> (X,W)) -> X -> B -> (X, B)) - ( mapAccumR :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) - -prop_mapAccumRDL :: (X -> Char8 -> (X, Char8)) -> X -> B -> Bool -prop_mapAccumRDL f = eq3 - (D.mapAccumR :: (X -> Char -> (X,Char)) -> X -> B -> (X, B)) - ( mapAccumR :: (X -> Char -> (X,Char)) -> X -> [Char] -> (X, [Char])) - (castFn f) - -prop_mapAccumRCC :: (X -> Char8 -> (X, Char8)) -> X -> P -> Bool -prop_mapAccumRCC f = eq3 - (C.mapAccumR :: (X -> Char -> (X,Char)) -> X -> P -> (X, P)) - ( mapAccumR :: (X -> Char -> (X,Char)) -> X -> [Char] -> (X, [Char])) - (castFn f) - -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]) - -prop_packZipWithBL = L.packZipWith `eq3` (zipWith :: (W -> W -> W) -> [W] -> [W] -> [W]) - --- --- And finally, check correspondance between Data.ByteString and List --- - -prop_lengthPL = (fromIntegral.P.length :: P -> Int) `eq1` (length :: [W] -> Int) -prop_nullPL = P.null `eq1` (null :: [W] -> Bool) -prop_reversePL = P.reverse `eq1` (reverse :: [W] -> [W]) -prop_transposePL = P.transpose `eq1` (transpose :: [[W]] -> [[W]]) -prop_groupPL = P.group `eq1` (group :: [W] -> [[W]]) -prop_groupByPL = P.groupBy `eq2` (groupBy :: (W -> W -> Bool) -> [W] -> [[W]]) -prop_initsPL = P.inits `eq1` (inits :: [W] -> [[W]]) -prop_tailsPL = P.tails `eq1` (tails :: [W] -> [[W]]) -prop_concatPL = forAll (sized $ \n -> resize (n `div` 2) arbitrary) $ - 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 = forAll (sized $ \n -> resize (n `div` 2) arbitrary) $ - 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_findIndexEndPL = P.findIndexEnd `eq2` (findIndexEnd :: (W -> Bool) -> [W] -> Maybe Int) -prop_isPrefixOfPL = P.isPrefixOf`eq2` (isPrefixOf:: [W] -> [W] -> Bool) -prop_isSuffixOfPL = P.isSuffixOf`eq2` (isSuffixOf:: [W] -> [W] -> Bool) -prop_isInfixOfPL = P.isInfixOf `eq2` (isInfixOf:: [W] -> [W] -> Bool) -prop_stripPrefixPL = P.stripPrefix`eq2` (stripPrefix:: [W] -> [W] -> Maybe [W]) -prop_stripSuffixPL = P.stripSuffix`eq2` (stripSuffix:: [W] -> [W] -> Maybe [W]) -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 :: [(Char8, Char8)] -> Bool -prop_unzipCL xs = (C.unzip `eq1` (unzip :: [(Char,Char)] -> ([Char],[Char]))) - [ (a,b) | (Char8 a, Char8 b) <- xs ] - -prop_unzipDL :: [(Char8, Char8)] -> Bool -prop_unzipDL xs = (D.unzip `eq1` (unzip :: [(Char,Char)] -> ([Char],[Char]))) - [ (a,b) | (Char8 a, Char8 b) <- xs ] - -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 :: (Char8 -> Char8 -> Char8) -> P -> Property -prop_scanrCL :: (Char8 -> Char8 -> Char8) -> Char8 -> P -> Property -prop_scanr1CL :: (Char8 -> Char8 -> Char8) -> P -> Property - -prop_scanl1CL f = eqnotnull2 - C.scanl1 - (scanl1 :: (Char -> Char -> Char) -> [Char] -> [Char]) - (castFn f) - -prop_scanrCL f (Char8 c) = eqnotnull3 - C.scanr - (scanr :: (Char -> Char -> Char) -> Char -> [Char] -> [Char]) - (castFn f) - c - -prop_scanr1CL f = eqnotnull2 - C.scanr1 - (scanr1 :: (Char -> Char -> Char) -> [Char] -> [Char]) - (castFn f) - -prop_packZipWithPL = P.packZipWith `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_compare9 = (L.singleton 255 `compare` L.singleton 127) == GT - -prop_compare7LL (Char8 x) (Char8 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_appendLazy xs = L.head (L.pack [xs] `L.append` error "Tail should be lazy") == xs - -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 = forAll (sized $ \n -> resize (n `div` 2) arbitrary) $ \xss -> - 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_compareLength1 xs = (L.pack xs `L.compareLength` fromIntegral (length xs)) == EQ -prop_compareLength2 xs c = (L.pack (xs ++ [c]) `L.compareLength` fromIntegral (length xs)) == GT -prop_compareLength3 xs c = (L.pack xs `L.compareLength` fromIntegral (length (xs ++ [c]))) == LT -prop_compareLength4 xs c = ((L.pack xs `L.append` L.pack [c] `L.append` L.pack [undefined]) - `L.compareLength` fromIntegral (length xs)) == GT -prop_compareLength5 xs l = L.compareLength xs l == compare (L.length xs) l - -prop_replicate1 c = - forAll arbitrary $ \(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_takeEnd i xs = P.takeEnd i xs == P.drop (P.length xs - i) xs - -prop_drop1 i xs = L.drop (fromIntegral i) (pack xs) == pack (drop i xs) -prop_dropEnd i xs = P.dropEnd i xs == P.take (P.length xs - 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_takeWhileEnd f = P.takeWhileEnd f `eq1` (P.reverse . P.takeWhile f . P.reverse) -prop_dropWhileEnd f = P.dropWhileEnd f `eq1` (P.reverse . P.dropWhile f . P.reverse) - -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_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_empty f = L.splitWith f mempty == [] - -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_empty f = D.splitWith f mempty == [] - -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_empty f = C.splitWith f mempty == [] - -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_split_empty c = L.split c mempty == [] - -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 :: (Char8 -> Char8 -> Bool) -> String8 -> Bool -prop_groupBy_LC f' (String8 xs) = - groupBy f xs == (map LC.unpack . LC.groupBy f . LC.pack) xs - where - f :: Char -> Char -> Bool - f = castFn f' - --- 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 (String8 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 (String8 xs) = - not (null xs) ==> - forAll indices $ \i -> (xs !! i) == C.pack xs `C.index` (fromIntegral i) - where indices = choose (0, length xs -1) - --- | Test 'indexMaybe' for Lazy and Strict 'ByteString's. --- If we are testing within the bounds it should return a 'Just' value. --- If we are testing outside of the bounds it should return a 'Nothing' value. -prop_indexMaybe_Just_L xs = - not (null xs) ==> - forAll indices $ \i -> isJust (ys `L.indexMaybe` (fromIntegral i)) - where - ys = L.pack xs - indices = choose (0, length xs -1) - -prop_indexMaybe_Just_P xs = - not (null xs) ==> - forAll indices $ \i -> isJust (ys `P.indexMaybe` (fromIntegral i)) - where - ys = P.pack xs - indices = choose (0, length xs -1) - -prop_indexMaybe_Nothing_L xs = - not (null xs) ==> - forAll indices $ \i -> isNothing (ys `L.indexMaybe` (fromIntegral i)) - where - ys = L.pack xs - outOfBounds = choose (-100, length xs + 100) - indices = suchThat outOfBounds (\n -> n < 0 || n >= length xs) - -prop_indexMaybe_Nothing_P xs = - not (null xs) ==> - forAll indices $ \i -> isNothing (ys `P.indexMaybe` (fromIntegral i)) - where - ys = P.pack xs - outOfBounds = choose (-100, length xs + 100) - indices = suchThat outOfBounds (\n -> n < 0 || n >= length xs) - -prop_elemIndex xs c = (elemIndex c xs) == fmap fromIntegral (L.elemIndex c (pack xs)) - -prop_elemIndexCL :: String8 -> Char8 -> Bool -prop_elemIndexCL (String8 xs) (Char8 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_findIndexEnd xs f = (findIndexEnd f xs) == fmap fromIntegral (L.findIndexEnd 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_stripPrefix xs ys = (pack <$> stripPrefix xs ys) == (pack xs `L.stripPrefix` pack ys) - -prop_isSuffixOf xs ys = isSuffixOf xs ys == (pack xs `L.isSuffixOf` pack ys) -prop_stripSuffix xs ys = (pack <$> stripSuffix xs ys) == (pack xs `L.stripSuffix` pack ys) - -{- -prop_sort1 xs = sort xs == (unpack . L.sort . pack) xs -prop_sort2 xs = (not (null xs)) ==> (L.head . L.sort . pack $ xs) == minimum xs -prop_sort3 xs = (not (null xs)) ==> (L.last . L.sort . pack $ xs) == maximum xs -prop_sort4 xs ys = - (not (null xs)) ==> - (not (null ys)) ==> - (L.head . L.sort) (L.append (pack xs) (pack ys)) == min (minimum xs) (minimum ys) - -prop_sort5 xs ys = - (not (null xs)) ==> - (not (null ys)) ==> - (L.last . L.sort) (L.append (pack xs) (pack ys)) == max (maximum xs) (maximum ys) - --} - ------------------------------------------------------------------------- --- Misc ByteString properties - -prop_nil1BB = P.length P.empty == 0 -prop_nil2BB = P.unpack P.empty == [] -prop_nil1BB_monoid = P.length mempty == 0 -prop_nil2BB_monoid = P.unpack mempty == [] - -prop_nil1LL_monoid = L.length mempty == 0 -prop_nil2LL_monoid = L.unpack mempty == [] - -prop_tailSBB xs = not (P.null xs) ==> P.tail xs == P.pack (tail (P.unpack xs)) - -prop_nullBB xs = null (P.unpack xs) == P.null xs - -prop_lengthBB xs = P.length xs == length1 xs - where - length1 ys - | P.null ys = 0 - | otherwise = 1 + length1 (P.tail ys) - -prop_lengthSBB xs = length xs == P.length (P.pack xs) - -prop_indexBB xs = - not (null xs) ==> - forAll indices $ \i -> (xs !! i) == P.pack xs `P.index` i - where indices = choose (0, length xs -1) - -prop_unsafeIndexBB xs = - not (null xs) ==> - forAll indices $ \i -> (xs !! i) == P.pack xs `P.unsafeIndex` i - where indices = choose (0, length xs -1) - -prop_mapfusionBB f g xs = P.map f (P.map g xs) == P.map (f . g) xs - -prop_filterBB f xs = P.filter f (P.pack xs) == P.pack (filter f xs) - -prop_filterfusionBB f g xs = P.filter f (P.filter g xs) == P.filter (\c -> f c && g c) xs - -prop_elemSBB x xs = P.elem x (P.pack xs) == elem x xs - -prop_takeSBB i xs = P.take i (P.pack xs) == P.pack (take i xs) -prop_dropSBB i xs = P.drop i (P.pack xs) == P.pack (drop i xs) - -prop_splitAtSBB i xs = -- collect (i >= 0 && i < length xs) $ - P.splitAt i (P.pack xs) == - let (a,b) = splitAt i xs in (P.pack a, P.pack b) - -prop_foldlBB f c xs = P.foldl f c (P.pack xs) == foldl f c xs - where _ = c :: Char - -prop_scanlfoldlBB f z xs = not (P.null xs) ==> P.last (P.scanl f z xs) == P.foldl f z xs - -prop_foldrBB f c xs = P.foldl f c (P.pack xs) == foldl f c xs - where _ = c :: Char - -prop_takeWhileSBB f xs = P.takeWhile f (P.pack xs) == P.pack (takeWhile f xs) -prop_dropWhileSBB f xs = P.dropWhile f (P.pack xs) == P.pack (dropWhile f xs) - -prop_spanSBB f xs = P.span f (P.pack xs) == - let (a,b) = span f xs in (P.pack a, P.pack b) - -prop_breakSBB f xs = P.break f (P.pack xs) == - let (a,b) = break f xs in (P.pack a, P.pack b) - -prop_breakspan_1BB xs c = P.break (== c) xs == P.span (/= c) xs - -prop_linesSBB (String8 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 (String8 xs) = - C.words (C.pack xs) == map C.pack (words xs) - -prop_wordsLC (String8 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_empty f = P.splitWith f mempty == [] - -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_splitBB_empty c = P.split c mempty == [] - -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 (Char8 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 (Char8 x) (Char8 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 (String8 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 (Char8 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_last1BB xs = (not (null xs)) ==> last xs == (P.unsafeLast . P.pack) xs - -prop_initBB xs = - (not (null xs)) ==> - init xs == (P.unpack . P.init . P.pack) xs -prop_init1BB xs = - (not (null xs)) ==> - init xs == (P.unpack . P.unsafeInit . 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 (String8 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_ne xs a = - (takeWhile (/= a) xs) == (P.unpack . (P.takeWhile (/= a)) . P.pack) xs -prop_takeWhileBB_eq xs a = - (takeWhile (== a) xs) == (P.unpack . (P.takeWhile (== a)) . P.pack) xs - -prop_dropWhileBB_ne xs a = - (dropWhile (/= a) xs) == (P.unpack . (P.dropWhile (/= a)) . P.pack) xs -prop_dropWhileBB_eq xs a = - (dropWhile (== a) xs) == (P.unpack . (P.dropWhile (== a)) . P.pack) xs - -prop_dropWhileCC_isSpace (String8 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 (String8 xs) = - (lines xs) == ((map C.unpack) . C.lines . C.pack) xs - -prop_unlinesBB (String8 xs) = - (unlines.lines) xs == (C.unpack. C.unlines . C.lines .C.pack) xs -prop_unlinesLC (String8 xs) = - (unlines.lines) xs == (LC.unpack. LC.unlines . LC.lines .LC.pack) xs - -prop_lines_lazy1 = - head (LC.lines (LC.append (LC.pack "a\nb\n") undefined)) == LC.pack "a" -prop_lines_lazy2 = - head (tail (LC.lines (LC.append (LC.pack "a\nb\n") undefined))) == LC.pack "b" - -prop_wordsBB (String8 xs) = - (words xs) == ((map C.unpack) . C.words . C.pack) xs --- prop_wordstokensBB xs = C.words xs == C.tokens isSpace xs - -prop_unwordsBB (String8 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_groupBy1BB xs = groupBy (/=) xs == (map P.unpack . P.groupBy (/=) . P.pack) xs -prop_groupBy1CC (String8 xs) = groupBy (==) xs == (map C.unpack . C.groupBy (==) . C.pack) xs -prop_groupBy2CC (String8 xs) = groupBy (/=) xs == (map C.unpack . C.groupBy (/=) . C.pack) xs - -prop_joinBB (String8 xs) (String8 ys) = - (concat . (intersperse ys) . lines) xs == - (C.unpack $ C.intercalate (C.pack ys) (C.lines (C.pack xs))) - -prop_elemIndex1BB (String8 xs) = (elemIndex 'X' xs) == (C.elemIndex 'X' (C.pack xs)) -prop_elemIndex2BB (String8 xs) (Char8 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 (Char8 c) (String8 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_elemIndexEnd1LL c xs = - L.elemIndexEnd c (L.pack xs) == - case L.elemIndex c (L.pack (reverse xs)) of - Nothing -> Nothing - Just i -> Just (fromIntegral (length xs) - 1 - i) - -prop_elemIndexEnd1DD (Char8 c) (String8 xs) = - D.elemIndexEnd c (D.pack xs) == - case D.elemIndex c (D.pack (reverse xs)) of - Nothing -> Nothing - Just i -> Just (fromIntegral (length xs) - 1 - i) - -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_findIndexEndBB xs a = (findIndexEnd (==a) xs) == (P.findIndexEnd (==a) (P.pack xs)) - -prop_findIndexEndLL xs a = (findIndexEnd (==a) xs) == fmap fromIntegral (L.findIndexEnd (==a) (L.pack xs)) - -prop_findIndexEndDD (String8 xs) (Char8 a) = (findIndexEnd (==a) xs) == fmap fromIntegral (D.findIndexEnd (==a) (D.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_strip = C.strip `eq1` (C.dropSpace . C.reverse . C.dropSpace . C.reverse) - --- 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, if x == maxBound then x else succ x) - -prop_prefixBB xs ys = isPrefixOf xs ys == (P.pack xs `P.isPrefixOf` P.pack ys) -prop_prefixLL xs ys = isPrefixOf xs ys == (L.pack xs `L.isPrefixOf` L.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_stripPrefixBB xs ys = (P.pack <$> stripPrefix xs ys) == (P.pack xs `P.stripPrefix` P.pack ys) -prop_stripPrefixLL xs ys = (L.pack <$> stripPrefix xs ys) == (L.pack xs `L.stripPrefix` L.pack ys) -prop_stripSuffixBB xs ys = (P.pack <$> stripSuffix xs ys) == (P.pack xs `P.stripSuffix` P.pack ys) -prop_stripSuffixLL xs ys = (L.pack <$> stripSuffix xs ys) == (L.pack xs `L.stripSuffix` 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)) - --- 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_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 (String8 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 (String8 s) = - let s' = filter (\c -> c `notElem` ['0'..'9']) s - in C.readInteger (C.pack s') == Nothing - - --- Ensure that readInt and readInteger over lazy ByteStrings are not --- excessively strict. -prop_readIntSafe = (fst . fromJust . D.readInt) (Chunk (C.pack "1z") Empty) == 1 -prop_readIntUnsafe = (fst . fromJust . D.readInt) (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_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 (String8 xs) (String8 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_packZipWithBB f xs ys = P.pack (P.zipWith f xs ys) == P.packZipWith f xs ys -prop_packZipWithLL f xs ys = L.pack (L.zipWith f xs ys) == L.packZipWith f xs ys -prop_packZipWithBC f xs ys = C.pack (C.zipWith f xs ys) == C.packZipWith f xs ys -prop_packZipWithLC f xs ys = LC.pack (LC.zipWith f xs ys) == LC.packZipWith f xs ys - - -prop_unzipBB x = let (xs,ys) = unzip x in (P.pack xs, P.pack ys) == P.unzip x - -#if MIN_VERSION_base(4,9,0) -prop_stimesBB :: NonNegative Int -> P.ByteString -> Bool -prop_stimesBB (NonNegative i) bs = stimes i bs == mtimesDefault i bs - -prop_stimesLL :: NonNegative Int -> L.ByteString -> Bool -prop_stimesLL (NonNegative i) bs = stimes i bs == mtimesDefault i bs -#endif - --- 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 - ------------------------------------------------------------------------- - --- Test IsString, Show, Read, pack, unpack -prop_isstring :: String8 -> Bool -prop_isstring_lc :: String8 -> Bool - -prop_isstring (String8 x) = C.unpack (fromString x :: C.ByteString) == x -prop_isstring_lc (String8 x) = LC.unpack (fromString x :: LC.ByteString) == x - -prop_showP1 x = show x == show (C.unpack x) -prop_showL1 x = show x == show (LC.unpack x) - -prop_readP1 x = read (show x) == (x :: P.ByteString) -prop_readP2 x = read (show x) == C.pack (x :: String) - -prop_readL1 x = read (show x) == (x :: L.ByteString) -prop_readL2 x = read (show x) == LC.pack (x :: String) - -prop_packunpack_s x = (P.unpack . P.pack) x == x -prop_unpackpack_s x = (P.pack . P.unpack) x == x - -prop_packunpack_c (String8 x) = (C.unpack . C.pack) x == x -prop_unpackpack_c x = (C.pack . C.unpack) x == x - -prop_packunpack_l x = (L.unpack . L.pack) x == x -prop_unpackpack_l x = (L.pack . L.unpack) x == x - -prop_packunpack_lc (String8 x) = (LC.unpack . LC.pack) x == x -prop_unpackpack_lc x = (LC.pack . LC.unpack) x == x - -prop_toFromChunks x = (L.fromChunks . L.toChunks) x == x -prop_fromToChunks x = (L.toChunks . L.fromChunks) x == filter (not . P.null) x - -prop_toFromStrict x = (L.fromStrict . L.toStrict) x == x -prop_fromToStrict x = (L.toStrict . L.fromStrict) x == x - -prop_packUptoLenBytes cs = - forAll (choose (0, length cs + 1)) $ \n -> - let (bs, cs') = P.packUptoLenBytes n cs - in P.length bs == min n (length cs) - && take n cs == P.unpack bs - && P.pack (take n cs) == bs - && drop n cs == cs' - -prop_packUptoLenChars (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_unpack_s cs = - forAll (choose (0, length cs)) $ \n -> - P.unpack (P.drop n $ P.pack cs) == drop n cs -prop_unpack_c (String8 cs) = - forAll (choose (0, length cs)) $ \n -> - C.unpack (C.drop n $ C.pack cs) == drop n cs - -prop_unpack_l cs = - forAll (choose (0, length cs)) $ \n -> - L.unpack (L.drop (fromIntegral n) $ L.pack cs) == drop n cs -prop_unpack_lc (String8 cs) = - forAll (choose (0, length cs)) $ \n -> - LC.unpack (L.drop (fromIntegral n) $ LC.pack cs) == drop n cs - -prop_unpackBytes cs = - forAll (choose (0, length cs)) $ \n -> - P.unpackBytes (P.drop n $ P.pack cs) == drop n cs -prop_unpackChars (String8 cs) = - forAll (choose (0, length cs)) $ \n -> - P.unpackChars (P.drop n $ C.pack cs) == drop n cs - -prop_unpackBytes_l = - forAll (sized $ \n -> resize (n * 10) arbitrary) $ \cs -> - forAll (choose (0, length cs)) $ \n -> - L.unpackBytes (L.drop (fromIntegral n) $ L.pack cs) == drop n cs -prop_unpackChars_l = - forAll (sized $ \n -> resize (n * 10) arbitrary) $ \(String8 cs) -> - forAll (choose (0, length cs)) $ \n -> - L.unpackChars (L.drop (fromIntegral n) $ LC.pack cs) == drop n cs - -prop_unpackAppendBytesLazy cs' = - forAll (sized $ \n -> resize (n * 10) arbitrary) $ \cs -> - forAll (choose (0, 2)) $ \n -> - P.unpackAppendBytesLazy (P.drop n $ P.pack cs) cs' == drop n cs ++ cs' -prop_unpackAppendCharsLazy (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_internal_invariant x = L.invariant x - -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) #) - -stripSuffix :: [W] -> [W] -> Maybe [W] -stripSuffix xs ys = reverse <$> stripPrefix (reverse xs) (reverse ys) - -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 - ] - ------------------------------------------------------------------------- --- The entry point - -main :: IO () -main = defaultMain $ testGroup "All" tests - --- --- And now a list of all the properties to test. --- - -tests = misc_tests - ++ bl_tests - ++ cc_tests - ++ bp_tests - ++ pl_tests - ++ bb_tests - ++ ll_tests - ++ io_tests - ++ short_tests - ++ rules - --- --- 'morally sound' IO --- -io_tests = - [ testProperty "readFile.writeFile" prop_read_write_file_P - , testProperty "readFile.writeFile" prop_read_write_file_C - , testProperty "readFile.writeFile" prop_read_write_file_L - , testProperty "readFile.writeFile" prop_read_write_file_D - - , testProperty "appendFile " prop_append_file_P - , testProperty "appendFile " prop_append_file_C - , testProperty "appendFile " prop_append_file_L - , testProperty "appendFile " prop_append_file_D - - , testProperty "packAddress " prop_packAddress - - ] - -misc_tests = - [ testProperty "packunpack (bytes)" prop_packunpack_s - , testProperty "unpackpack (bytes)" prop_unpackpack_s - , testProperty "packunpack (chars)" prop_packunpack_c - , testProperty "unpackpack (chars)" prop_unpackpack_c - , testProperty "packunpack (lazy bytes)" prop_packunpack_l - , testProperty "unpackpack (lazy bytes)" prop_unpackpack_l - , testProperty "packunpack (lazy chars)" prop_packunpack_lc - , testProperty "unpackpack (lazy chars)" prop_unpackpack_lc - , testProperty "unpack (bytes)" prop_unpack_s - , testProperty "unpack (chars)" prop_unpack_c - , testProperty "unpack (lazy bytes)" prop_unpack_l - , testProperty "unpack (lazy chars)" prop_unpack_lc - , testProperty "packUptoLenBytes" prop_packUptoLenBytes - , testProperty "packUptoLenChars" prop_packUptoLenChars - , testProperty "unpackBytes" prop_unpackBytes - , testProperty "unpackChars" prop_unpackChars - , testProperty "unpackBytes" prop_unpackBytes_l - , testProperty "unpackChars" prop_unpackChars_l - , testProperty "unpackAppendBytesLazy" prop_unpackAppendBytesLazy - , testProperty "unpackAppendCharsLazy" prop_unpackAppendCharsLazy - , testProperty "unpackAppendBytesStrict"prop_unpackAppendBytesStrict - , testProperty "unpackAppendCharsStrict"prop_unpackAppendCharsStrict - , testProperty "toFromChunks" prop_toFromChunks - , testProperty "fromToChunks" prop_fromToChunks - , testProperty "toFromStrict" prop_toFromStrict - , testProperty "fromToStrict" prop_fromToStrict - - , testProperty "invariant" prop_invariant - , testProperty "unsafe pack address" prop_unsafePackAddress - , testProperty "unsafe pack address len"prop_unsafePackAddressLen - , testProperty "unsafeUseAsCString" prop_unsafeUseAsCString - , testProperty "unsafeUseAsCStringLen" prop_unsafeUseAsCStringLen - , testProperty "useAsCString" prop_useAsCString - , testProperty "packCString" prop_packCString - , testProperty "packCString safe" prop_packCString_safe - , testProperty "packCStringLen" prop_packCStringLen - , testProperty "packCStringLen safe" prop_packCStringLen_safe - , testProperty "packCStringFinaliser" prop_packCStringFinaliser - , testProperty "packMallocString" prop_packMallocCString - , testProperty "unsafeFinalise" prop_unsafeFinalize - , testProperty "invariant" prop_internal_invariant - , testProperty "show 1" prop_showP1 - , testProperty "show 2" prop_showL1 - , testProperty "read 1" prop_readP1 - , testProperty "read 2" prop_readP2 - , testProperty "read 3" prop_readL1 - , testProperty "read 4" prop_readL2 - , testProperty "fromForeignPtr" prop_fromForeignPtr - ] - ------------------------------------------------------------------------- --- ByteString.Lazy <=> List - -bl_tests = - [ testProperty "all" prop_allBL - , testProperty "any" prop_anyBL - , testProperty "append" prop_appendBL - , testProperty "compare" prop_compareBL - , testProperty "concat" prop_concatBL - , testProperty "cons" prop_consBL - , testProperty "eq" prop_eqBL - , testProperty "filter" prop_filterBL - , testProperty "find" prop_findBL - , testProperty "findIndex" prop_findIndexBL - , testProperty "findIndexEnd"prop_findIndexEndBL - , testProperty "findIndices" prop_findIndicesBL - , testProperty "foldl" prop_foldlBL - , testProperty "foldl'" prop_foldlBL' - , testProperty "foldl1" prop_foldl1BL - , testProperty "foldl1'" prop_foldl1BL' - , testProperty "foldr" prop_foldrBL - , testProperty "foldr1" prop_foldr1BL - , testProperty "mapAccumL" prop_mapAccumLBL - , testProperty "mapAccumR" prop_mapAccumRBL - , testProperty "mapAccumR" prop_mapAccumRDL - , testProperty "mapAccumR" prop_mapAccumRCC - , testProperty "unfoldr" prop_unfoldrBL - , testProperty "unfoldr" prop_unfoldrLC - , testProperty "unfoldr" prop_cycleLC - , testProperty "iterate" prop_iterateLC - , testProperty "iterate" prop_iterateLC_2 - , testProperty "iterate" prop_iterateL - , testProperty "repeat" prop_repeatLC - , testProperty "repeat" prop_repeatL - , testProperty "head" prop_headBL - , testProperty "init" prop_initBL - , testProperty "isPrefixOf" prop_isPrefixOfBL - , testProperty "isSuffixOf" prop_isSuffixOfBL - , testProperty "stripPrefix" prop_stripPrefixBL - , testProperty "stripSuffix" prop_stripSuffixBL - , testProperty "last" prop_lastBL - , testProperty "length" prop_lengthBL - , testProperty "map" prop_mapBL - , testProperty "maximum" prop_maximumBL - , testProperty "minimum" prop_minimumBL - , testProperty "null" prop_nullBL - , testProperty "reverse" prop_reverseBL - , testProperty "snoc" prop_snocBL - , testProperty "tail" prop_tailBL - , testProperty "transpose" prop_transposeBL - , testProperty "replicate" prop_replicateBL - , testProperty "take" prop_takeBL - , testProperty "drop" prop_dropBL - , testProperty "splitAt" prop_splitAtBL - , testProperty "takeWhile" prop_takeWhileBL - , testProperty "dropWhile" prop_dropWhileBL - , testProperty "break" prop_breakBL - , testProperty "span" prop_spanBL - , testProperty "group" prop_groupBL - , testProperty "groupBy" prop_groupByBL - , testProperty "inits" prop_initsBL - , testProperty "tails" prop_tailsBL - , testProperty "elem" prop_elemBL - , testProperty "notElem" prop_notElemBL - , testProperty "lines" prop_linesBL - , testProperty "elemIndex" prop_elemIndexBL - , testProperty "elemIndexEnd"prop_elemIndexEndBL - , testProperty "elemIndices" prop_elemIndicesBL - , testProperty "concatMap" prop_concatMapBL - , testProperty "zipWith/packZipWithLazy" prop_packZipWithBL - ] - ------------------------------------------------------------------------- --- ByteString.Lazy <=> ByteString - -cc_tests = - [ testProperty "prop_concatCC" prop_concatCC - , testProperty "prop_nullCC" prop_nullCC - , testProperty "prop_reverseCC" prop_reverseCC - , testProperty "prop_transposeCC" prop_transposeCC - , testProperty "prop_groupCC" prop_groupCC - , testProperty "prop_groupByCC" prop_groupByCC - , testProperty "prop_initsCC" prop_initsCC - , testProperty "prop_tailsCC" prop_tailsCC - , testProperty "prop_allCC" prop_allCC - , testProperty "prop_anyCC" prop_anyCC - , testProperty "prop_appendCC" prop_appendCC - , testProperty "prop_breakCC" prop_breakCC - , testProperty "prop_concatMapCC" prop_concatMapCC - , testProperty "prop_consCC" prop_consCC - , testProperty "prop_consCC'" prop_consCC' - , testProperty "prop_unconsCC" prop_unconsCC - , testProperty "prop_unsnocCC" prop_unsnocCC - , testProperty "prop_countCC" prop_countCC - , testProperty "prop_dropCC" prop_dropCC - , testProperty "prop_dropWhileCC" prop_dropWhileCC - , testProperty "prop_filterCC" prop_filterCC - , testProperty "prop_findCC" prop_findCC - , testProperty "prop_findIndexCC" prop_findIndexCC - , testProperty "prop_findIndexEndCC" prop_findIndexEndCC - , testProperty "prop_findIndicesCC" prop_findIndicesCC - , testProperty "prop_isPrefixCC" prop_isPrefixOfCC - , testProperty "prop_isSuffixCC" prop_isSuffixOfCC - , testProperty "prop_stripPrefixCC" prop_stripPrefixCC - , testProperty "prop_stripSuffixCC" prop_stripSuffixCC - , testProperty "prop_mapCC" prop_mapCC - , testProperty "prop_replicateCC" prop_replicateCC - , testProperty "prop_snocCC" prop_snocCC - , testProperty "prop_spanCC" prop_spanCC - , testProperty "prop_splitCC" prop_splitCC - , testProperty "prop_splitAtCC" prop_splitAtCC - , testProperty "prop_takeCC" prop_takeCC - , testProperty "prop_takeWhileCC" prop_takeWhileCC - , testProperty "prop_elemCC" prop_elemCC - , testProperty "prop_notElemCC" prop_notElemCC - , testProperty "prop_elemIndexCC" prop_elemIndexCC - , testProperty "prop_elemIndicesCC" prop_elemIndicesCC - , testProperty "prop_lengthCC" prop_lengthCC - , testProperty "prop_headCC" prop_headCC - , testProperty "prop_initCC" prop_initCC - , testProperty "prop_lastCC" prop_lastCC - , testProperty "prop_maximumCC" prop_maximumCC - , testProperty "prop_minimumCC" prop_minimumCC - , testProperty "prop_tailCC" prop_tailCC - , testProperty "prop_foldl1CC" prop_foldl1CC - , testProperty "prop_foldl1CC'" prop_foldl1CC' - , testProperty "prop_foldr1CC" prop_foldr1CC - , testProperty "prop_foldr1CC'" prop_foldr1CC' - , testProperty "prop_scanlCC" prop_scanlCC - , testProperty "prop_intersperseCC" prop_intersperseCC - - , testProperty "prop_foldlCC" prop_foldlCC - , testProperty "prop_foldlCC'" prop_foldlCC' - , testProperty "prop_foldrCC" prop_foldrCC - , testProperty "prop_foldrCC'" prop_foldrCC' - , testProperty "prop_mapAccumLCC" prop_mapAccumLCC --- , testProperty "prop_mapIndexedCC" prop_mapIndexedCC --- , testProperty "prop_mapIndexedPL" prop_mapIndexedPL - ] - -bp_tests = - [ testProperty "all" prop_allBP - , testProperty "any" prop_anyBP - , testProperty "append" prop_appendBP - , testProperty "compare" prop_compareBP - , testProperty "concat" prop_concatBP - , testProperty "cons" prop_consBP - , testProperty "cons'" prop_consBP' - , testProperty "uncons" prop_unconsBP - , testProperty "unsnoc" prop_unsnocBP - , testProperty "eq" prop_eqBP - , testProperty "filter" prop_filterBP - , testProperty "find" prop_findBP - , testProperty "findIndex" prop_findIndexBP - , testProperty "findIndexEnd"prop_findIndexEndBP - , testProperty "findIndices" prop_findIndicesBP - , testProperty "foldl" prop_foldlBP - , testProperty "foldl'" prop_foldlBP' - , testProperty "foldl1" prop_foldl1BP - , testProperty "foldl1'" prop_foldl1BP' - , testProperty "foldr" prop_foldrBP - , testProperty "foldr'" prop_foldrBP' - , testProperty "foldr1" prop_foldr1BP - , testProperty "foldr1'" prop_foldr1BP' - , testProperty "mapAccumL" prop_mapAccumLBP --- , testProperty "mapAccumL" prop_mapAccumL_mapIndexedBP - , testProperty "unfoldr" prop_unfoldrBP - , testProperty "unfoldr 2" prop_unfoldr2BP - , testProperty "unfoldr 2" prop_unfoldr2CP - , testProperty "head" prop_headBP - , testProperty "init" prop_initBP - , testProperty "isPrefixOf" prop_isPrefixOfBP - , testProperty "isSuffixOf" prop_isSuffixOfBP - , testProperty "stripPrefix" prop_stripPrefixBP - , testProperty "stripSuffix" prop_stripSuffixBP - , testProperty "last" prop_lastBP - , testProperty "length" prop_lengthBP - , testProperty "readInt" prop_readIntBP - , testProperty "lines" prop_linesBP - , testProperty "lines \\n" prop_linesNLBP - , testProperty "map" prop_mapBP - , testProperty "maximum " prop_maximumBP - , testProperty "minimum" prop_minimumBP - , testProperty "null" prop_nullBP - , testProperty "reverse" prop_reverseBP - , testProperty "snoc" prop_snocBP - , testProperty "tail" prop_tailBP - , testProperty "scanl" prop_scanlBP - , testProperty "transpose" prop_transposeBP - , testProperty "replicate" prop_replicateBP - , testProperty "take" prop_takeBP - , testProperty "drop" prop_dropBP - , testProperty "splitAt" prop_splitAtBP - , testProperty "takeWhile" prop_takeWhileBP - , testProperty "dropWhile" prop_dropWhileBP - , testProperty "break" prop_breakBP - , testProperty "span" prop_spanBP - , testProperty "split" prop_splitBP - , testProperty "count" prop_countBP - , testProperty "group" prop_groupBP - , testProperty "groupBy" prop_groupByBP - , testProperty "inits" prop_initsBP - , testProperty "tails" prop_tailsBP - , testProperty "elem" prop_elemBP - , testProperty "notElem" prop_notElemBP - , testProperty "elemIndex" prop_elemIndexBP - , testProperty "elemIndexEnd"prop_elemIndexEndBP - , testProperty "elemIndices" prop_elemIndicesBP - , testProperty "intersperse" prop_intersperseBP - , testProperty "concatMap" prop_concatMapBP - ] - ------------------------------------------------------------------------- --- ByteString <=> List - -pl_tests = - [ testProperty "all" prop_allPL - , testProperty "any" prop_anyPL - , testProperty "append" prop_appendPL - , testProperty "compare" prop_comparePL - , testProperty "concat" prop_concatPL - , testProperty "cons" prop_consPL - , testProperty "eq" prop_eqPL - , testProperty "filter" prop_filterPL - , testProperty "filter rules"prop_filterPL_rule - , testProperty "filter rules"prop_filterLC_rule - , testProperty "partition" prop_partitionPL - , testProperty "partition" prop_partitionLL - , testProperty "find" prop_findPL - , testProperty "findIndex" prop_findIndexPL - , testProperty "findIndexEnd"prop_findIndexEndPL - , testProperty "findIndices" prop_findIndicesPL - , testProperty "foldl" prop_foldlPL - , testProperty "foldl'" prop_foldlPL' - , testProperty "foldl1" prop_foldl1PL - , testProperty "foldl1'" prop_foldl1PL' - , testProperty "foldr1" prop_foldr1PL - , testProperty "foldr" prop_foldrPL - , testProperty "mapAccumL" prop_mapAccumLPL - , testProperty "mapAccumR" prop_mapAccumRPL - , testProperty "unfoldr" prop_unfoldrPL - , testProperty "scanl" prop_scanlPL - , testProperty "scanl1" prop_scanl1PL - , testProperty "scanl1" prop_scanl1CL - , testProperty "scanr" prop_scanrCL - , testProperty "scanr" prop_scanrPL - , testProperty "scanr1" prop_scanr1PL - , testProperty "scanr1" prop_scanr1CL - , testProperty "head" prop_headPL - , testProperty "init" prop_initPL - , testProperty "last" prop_lastPL - , testProperty "maximum" prop_maximumPL - , testProperty "minimum" prop_minimumPL - , testProperty "tail" prop_tailPL - , testProperty "zip" prop_zipPL - , testProperty "zip" prop_zipLL - , testProperty "zip" prop_zipCL - , testProperty "unzip" prop_unzipPL - , testProperty "unzip" prop_unzipLL - , testProperty "unzip" prop_unzipCL - , testProperty "unzip" prop_unzipDL - , testProperty "zipWithPL" prop_zipWithPL - , testProperty "zipWithPL rules" prop_zipWithPL_rules - , testProperty "packZipWithPL" prop_packZipWithPL - - , testProperty "isPrefixOf" prop_isPrefixOfPL - , testProperty "isSuffixOf" prop_isSuffixOfPL - , testProperty "isInfixOf" prop_isInfixOfPL - , testProperty "stripPrefix" prop_stripPrefixPL - , testProperty "stripSuffix" prop_stripSuffixPL - , testProperty "length" prop_lengthPL - , testProperty "map" prop_mapPL - , testProperty "null" prop_nullPL - , testProperty "reverse" prop_reversePL - , testProperty "snoc" prop_snocPL - , testProperty "transpose" prop_transposePL - , testProperty "replicate" prop_replicatePL - , testProperty "take" prop_takePL - , testProperty "drop" prop_dropPL - , testProperty "splitAt" prop_splitAtPL - , testProperty "takeWhile" prop_takeWhilePL - , testProperty "dropWhile" prop_dropWhilePL - , testProperty "break" prop_breakPL - , testProperty "span" prop_spanPL - , testProperty "group" prop_groupPL - , testProperty "groupBy" prop_groupByPL - , testProperty "inits" prop_initsPL - , testProperty "tails" prop_tailsPL - , testProperty "elem" prop_elemPL - , testProperty "notElem" prop_notElemPL - , testProperty "lines" prop_linesPL - , testProperty "elemIndex" prop_elemIndexPL - , testProperty "elemIndex" prop_elemIndexCL - , testProperty "elemIndices" prop_elemIndicesPL - , testProperty "concatMap" prop_concatMapPL - , testProperty "IsString" prop_isstring - , testProperty "IsString LC" prop_isstring_lc - ] - ------------------------------------------------------------------------- --- extra ByteString properties - -bb_tests = - [ testProperty "bijection" prop_bijectionBB - , testProperty "bijection'" prop_bijectionBB' - , testProperty "pack/unpack" prop_packunpackBB - , testProperty "unpack/pack" prop_packunpackBB' - , testProperty "eq 1" prop_eq1BB - , testProperty "eq 2" prop_eq2BB - , testProperty "eq 3" prop_eq3BB - , testProperty "compare 1" prop_compare1BB - , testProperty "compare 2" prop_compare2BB - , testProperty "compare 3" prop_compare3BB - , testProperty "compare 4" prop_compare4BB - , testProperty "compare 5" prop_compare5BB - , testProperty "compare 6" prop_compare6BB - , testProperty "compare 7" prop_compare7BB - , testProperty "compare 7" prop_compare7LL - , testProperty "compare 8" prop_compare8BB - , testProperty "empty 1" prop_nil1BB - , testProperty "empty 2" prop_nil2BB - , testProperty "empty 1 monoid" prop_nil1LL_monoid - , testProperty "empty 2 monoid" prop_nil2LL_monoid - , testProperty "empty 1 monoid" prop_nil1BB_monoid - , testProperty "empty 2 monoid" prop_nil2BB_monoid - - , testProperty "null" prop_nullBB - , testProperty "length 1" prop_lengthBB - , testProperty "length 2" prop_lengthSBB - , testProperty "cons 1" prop_consBB - , testProperty "cons 2" prop_cons1BB - , testProperty "cons 3" prop_cons2BB - , testProperty "cons 4" prop_cons3BB - , testProperty "cons 5" prop_cons4BB - , testProperty "snoc" prop_snoc1BB - , testProperty "head 1" prop_head1BB - , testProperty "head 2" prop_head2BB - , testProperty "head 3" prop_head3BB - , testProperty "tail" prop_tailBB - , testProperty "tail 1" prop_tail1BB - , testProperty "last" prop_lastBB - , testProperty "last 1" prop_last1BB - , testProperty "init" prop_initBB - , testProperty "init 1" prop_init1BB - , testProperty "append 1" prop_append1BB - , testProperty "append 2" prop_append2BB - , testProperty "append 3" prop_append3BB - , testProperty "mappend 1" prop_append1BB_monoid - , testProperty "mappend 2" prop_append2BB_monoid - , testProperty "mappend 3" prop_append3BB_monoid - - , testProperty "map 1" prop_map1BB - , testProperty "map 2" prop_map2BB - , testProperty "map 3" prop_map3BB - , testProperty "filter1" prop_filter1BB - , testProperty "filter2" prop_filter2BB - , testProperty "map fusion" prop_mapfusionBB - , testProperty "filter fusion" prop_filterfusionBB - , testProperty "reverse 1" prop_reverse1BB - , testProperty "reverse 2" prop_reverse2BB - , testProperty "reverse 3" prop_reverse3BB - , testProperty "foldl 1" prop_foldl1BB - , testProperty "foldl 2" prop_foldl2BB - , testProperty "foldr 1" prop_foldr1BB - , testProperty "foldr 2" prop_foldr2BB - , testProperty "foldl1 1" prop_foldl1_1BB - , testProperty "foldl1 2" prop_foldl1_2BB - , testProperty "foldl1 3" prop_foldl1_3BB - , testProperty "foldr1 1" prop_foldr1_1BB - , testProperty "foldr1 2" prop_foldr1_2BB - , testProperty "foldr1 3" prop_foldr1_3BB - , testProperty "scanl/foldl" prop_scanlfoldlBB - , testProperty "all" prop_allBB - , testProperty "any" prop_anyBB - , testProperty "take" prop_takeBB - , testProperty "drop" prop_dropBB - , testProperty "takeWhile_ne" prop_takeWhileBB_ne - , testProperty "takeWhile_eq" prop_takeWhileBB_eq - , testProperty "dropWhile_ne" prop_dropWhileBB_ne - , testProperty "dropWhile_eq" prop_dropWhileBB_eq - , testProperty "dropWhile_isSpace" prop_dropWhileCC_isSpace - , testProperty "splitAt" prop_splitAtBB - , testProperty "span" prop_spanBB - , testProperty "break" prop_breakBB - , testProperty "elem" prop_elemBB - , testProperty "notElem" prop_notElemBB - - , testProperty "concat 1" prop_concat1BB - , testProperty "concat 2" prop_concat2BB - , testProperty "concat 3" prop_concatBB - , testProperty "mconcat 1" prop_concat1BB_monoid - , testProperty "mconcat 2" prop_concat2BB_monoid - , testProperty "mconcat 3" prop_concatBB_monoid - - , testProperty "mconcat 1" prop_concat1LL_monoid - , testProperty "mconcat 2" prop_concat2LL_monoid - , testProperty "mconcat 3" prop_concatLL_monoid - - , testProperty "lines" prop_linesBB - , testProperty "unlines" prop_unlinesBB - , testProperty "unlines" prop_unlinesLC - , testProperty "lines_lazy1" prop_lines_lazy1 - , testProperty "lines_lazy2" prop_lines_lazy2 - , testProperty "words" prop_wordsBB - , testProperty "words" prop_wordsLC - , testProperty "unwords" prop_unwordsBB - , testProperty "group" prop_groupBB - , testProperty "groupBy 0" prop_groupByBB - , testProperty "groupBy 1" prop_groupBy1CC - , testProperty "groupBy 2" prop_groupBy1BB - , testProperty "groupBy 3" prop_groupBy2CC - , testProperty "join" prop_joinBB - , testProperty "elemIndex 1" prop_elemIndex1BB - , testProperty "elemIndex 2" prop_elemIndex2BB - , testProperty "findIndex" prop_findIndexBB - , testProperty "findIndexEnd" prop_findIndexEndBB - , testProperty "findIndexEnd" prop_findIndexEndLL - , testProperty "findIndexEnd" prop_findIndexEndDD - , testProperty "findIndicies" prop_findIndiciesBB - , testProperty "elemIndices" prop_elemIndicesBB - , testProperty "find" prop_findBB - , testProperty "find/findIndex" prop_find_findIndexBB - , testProperty "sort 1" prop_sort1BB - , testProperty "sort 2" prop_sort2BB - , testProperty "sort 3" prop_sort3BB - , testProperty "sort 4" prop_sort4BB - , testProperty "sort 5" prop_sort5BB - , testProperty "intersperse" prop_intersperseBB - , testProperty "maximum" prop_maximumBB - , testProperty "minimum" prop_minimumBB - , testProperty "strip" prop_strip --- , testProperty "breakChar" prop_breakCharBB --- , testProperty "spanChar 1" prop_spanCharBB --- , testProperty "spanChar 2" prop_spanChar_1BB --- , testProperty "breakSpace" prop_breakSpaceBB --- , testProperty "dropSpace" prop_dropSpaceBB - , testProperty "spanEnd" prop_spanEndBB - , testProperty "breakEnd" prop_breakEndBB - , testProperty "breakEnd" prop_breakEndCC - , testProperty "elemIndexEnd" prop_elemIndexEnd1BB - , testProperty "elemIndexEnd" prop_elemIndexEnd1CC - , testProperty "elemIndexEnd" prop_elemIndexEnd1LL - , testProperty "elemIndexEnd" prop_elemIndexEnd1DD --- , testProperty "words'" prop_wordsBB' --- , testProperty "lines'" prop_linesBB' --- , testProperty "dropSpaceEnd" prop_dropSpaceEndBB - , testProperty "unfoldr" prop_unfoldrBB - , testProperty "prefix" prop_prefixBB - , testProperty "prefix" prop_prefixLL - , testProperty "suffix" prop_suffixBB - , testProperty "suffix" prop_suffixLL - , testProperty "stripPrefix" prop_stripPrefixBB - , testProperty "stripPrefix" prop_stripPrefixLL - , testProperty "stripSuffix" prop_stripSuffixBB - , testProperty "stripSuffix" prop_stripSuffixLL - , testProperty "copy" prop_copyBB - , testProperty "copy" prop_copyLL - , testProperty "inits" prop_initsBB - , testProperty "tails" prop_tailsBB - , testProperty "breakSubstring 1"prop_breakSubstringBB - , testProperty "breakSubstring 3"prop_breakSubstring_isInfixOf - - , testProperty "replicate1" prop_replicate1BB - , testProperty "replicate2" prop_replicate2BB - , testProperty "replicate3" prop_replicate3BB - , testProperty "readInt" prop_readintBB - , testProperty "readInt 2" prop_readint2BB - , testProperty "readInteger" prop_readintegerBB - , testProperty "readInteger 2" prop_readinteger2BB - , testProperty "read" prop_readLL - , testProperty "read" prop_readBB - , testProperty "Lazy.readInt" prop_readintLL - , testProperty "Lazy.readInt" prop_readintLL - , testProperty "Lazy.readInteger" prop_readintegerLL - - , testProperty "readIntSafe" prop_readIntSafe - , testProperty "readIntUnsafe" prop_readIntUnsafe - , testProperty "readIntegerSafe" prop_readIntegerSafe - , testProperty "readIntegerUnsafe" prop_readIntegerUnsafe - - , testProperty "mconcat 1" prop_append1LL_monoid - , testProperty "mconcat 2" prop_append2LL_monoid - , testProperty "mconcat 3" prop_append3LL_monoid --- , testProperty "filterChar1" prop_filterChar1BB --- , testProperty "filterChar2" prop_filterChar2BB --- , testProperty "filterChar3" prop_filterChar3BB --- , testProperty "filterNotChar1" prop_filterNotChar1BB --- , testProperty "filterNotChar2" prop_filterNotChar2BB - , testProperty "tail" prop_tailSBB - , testProperty "index" prop_indexBB - , testProperty "unsafeIndex" prop_unsafeIndexBB --- , testProperty "map'" prop_mapBB' - , testProperty "filter" prop_filterBB - , testProperty "elem" prop_elemSBB - , testProperty "take" prop_takeSBB - , testProperty "drop" prop_dropSBB - , testProperty "splitAt" prop_splitAtSBB - , testProperty "foldl" prop_foldlBB - , testProperty "foldr" prop_foldrBB - , testProperty "takeWhile " prop_takeWhileSBB - , testProperty "dropWhile " prop_dropWhileSBB - , testProperty "span " prop_spanSBB - , testProperty "break " prop_breakSBB - , testProperty "breakspan" prop_breakspan_1BB - , testProperty "lines " prop_linesSBB - , testProperty "unlines " prop_unlinesSBB - , testProperty "words " prop_wordsSBB - , testProperty "unwords " prop_unwordsSBB - , testProperty "unwords " prop_unwordsSLC --- , testProperty "wordstokens" prop_wordstokensBB - , testProperty "splitWith_empty" prop_splitWithBB_empty - , testProperty "splitWith" prop_splitWithBB - , testProperty "split_empty" prop_splitBB_empty - , testProperty "joinsplit" prop_joinsplitBB - , testProperty "intercalate" prop_intercalatePL --- , testProperty "lineIndices" prop_lineIndices1BB - , testProperty "count" prop_countBB --- , testProperty "linessplit" prop_linessplit2BB - , testProperty "splitsplitWith" prop_splitsplitWithBB --- , testProperty "joinjoinpath" prop_joinjoinpathBB - , testProperty "zip" prop_zipBB - , testProperty "zip" prop_zipLC - , testProperty "zip1" prop_zip1BB - , testProperty "zipWithBB" prop_zipWithBB - , testProperty "zipWithCC" prop_zipWithCC - , testProperty "zipWithLC" prop_zipWithLC - , testProperty "packZipWithBB" prop_packZipWithBB - , testProperty "packZipWithLL" prop_packZipWithLL - , testProperty "packZipWithBC" prop_packZipWithBC - , testProperty "packZipWithLC" prop_packZipWithLC - , testProperty "unzip" prop_unzipBB - , testProperty "concatMap" prop_concatMapBB --- , testProperty "join/joinByte" prop_join_spec -#if MIN_VERSION_base(4,9,0) - , testProperty "stimes strict" prop_stimesBB - , testProperty "stimes lazy" prop_stimesLL -#endif - ] - - ------------------------------------------------------------------------- --- Extra lazy properties - -ll_tests = - [ testProperty "eq 1" prop_eq1 - , testProperty "eq 2" prop_eq2 - , testProperty "eq 3" prop_eq3 - , testProperty "eq refl" prop_eq_refl - , testProperty "eq symm" prop_eq_symm - , testProperty "compare 1" prop_compare1 - , testProperty "compare 2" prop_compare2 - , testProperty "compare 3" prop_compare3 - , testProperty "compare 4" prop_compare4 - , testProperty "compare 5" prop_compare5 - , testProperty "compare 6" prop_compare6 - , testProperty "compare 7" prop_compare7 - , testProperty "compare 8" prop_compare8 - , testProperty "compare 9" prop_compare9 - , testProperty "empty 1" prop_empty1 - , testProperty "empty 2" prop_empty2 - , testProperty "pack/unpack" prop_packunpack - , testProperty "unpack/pack" prop_unpackpack - , testProperty "null" prop_null - , testProperty "length 1" prop_length1 - , testProperty "length 2" prop_length2 - , testProperty "cons 1" prop_cons1 - , testProperty "cons 2" prop_cons2 - , testProperty "cons 3" prop_cons3 - , testProperty "cons 4" prop_cons4 - , testProperty "snoc" prop_snoc1 - , testProperty "head/pack" prop_head - , testProperty "head/unpack" prop_head1 - , testProperty "tail/pack" prop_tail - , testProperty "tail/unpack" prop_tail1 - , testProperty "last" prop_last - , testProperty "init" prop_init - , testProperty "append 1" prop_append1 - , testProperty "appendLazy" prop_appendLazy - , testProperty "append 2" prop_append2 - , testProperty "append 3" prop_append3 - , testProperty "map 1" prop_map1 - , testProperty "map 2" prop_map2 - , testProperty "map 3" prop_map3 - , testProperty "filter 1" prop_filter1 - , testProperty "filter 2" prop_filter2 - , testProperty "reverse" prop_reverse - , testProperty "reverse1" prop_reverse1 - , testProperty "reverse2" prop_reverse2 - , testProperty "transpose" prop_transpose - , testProperty "foldl" prop_foldl - , testProperty "foldl/reverse" prop_foldl_1 - , testProperty "foldr" prop_foldr - , testProperty "foldr/id" prop_foldr_1 - , testProperty "foldl1/foldl" prop_foldl1_1 - , testProperty "foldl1/head" prop_foldl1_2 - , testProperty "foldl1/tail" prop_foldl1_3 - , testProperty "foldr1/foldr" prop_foldr1_1 - , testProperty "foldr1/last" prop_foldr1_2 - , testProperty "foldr1/head" prop_foldr1_3 - , testProperty "concat 1" prop_concat1 - , testProperty "concat 2" prop_concat2 - , testProperty "concat/pack" prop_concat3 - , testProperty "any" prop_any - , testProperty "all" prop_all - , testProperty "maximum" prop_maximum - , testProperty "minimum" prop_minimum - , testProperty "compareLength 1" prop_compareLength1 - , testProperty "compareLength 2" prop_compareLength2 - , testProperty "compareLength 3" prop_compareLength3 - , testProperty "compareLength 4" prop_compareLength4 - , testProperty "compareLength 5" prop_compareLength5 - , testProperty "replicate 1" prop_replicate1 - , testProperty "replicate 2" prop_replicate2 - , testProperty "take" prop_take1 - , testProperty "takeEnd" prop_takeEnd - , testProperty "drop" prop_drop1 - , testProperty "dropEnd" prop_dropEnd - , testProperty "splitAt" prop_drop1 - , testProperty "takeWhile" prop_takeWhile - , testProperty "dropWhile" prop_dropWhile - , testProperty "takeWhileEnd" prop_takeWhileEnd - , testProperty "dropWhileEnd" prop_dropWhileEnd - , testProperty "break" prop_break - , testProperty "span" prop_span - , testProperty "splitAt" prop_splitAt - , testProperty "break/span" prop_breakspan - , testProperty "split" prop_split - , testProperty "splitWith_empty" prop_splitWith_empty - , testProperty "splitWith" prop_splitWith - , testProperty "splitWith_empty" prop_splitWith_D_empty - , testProperty "splitWith" prop_splitWith_D - , testProperty "splitWith_empty" prop_splitWith_C_empty - , testProperty "splitWith" prop_splitWith_C - , testProperty "split_empty" prop_split_empty - , testProperty "join.split/id" prop_joinsplit --- , testProperty "join/joinByte" prop_joinjoinByte - , testProperty "group" prop_group - , testProperty "groupBy" prop_groupBy - , testProperty "groupBy" prop_groupBy_LC - , testProperty "index" prop_index - , testProperty "index" prop_index_D - , testProperty "index" prop_index_C - , testProperty "indexMaybe" prop_indexMaybe_Just_P - , testProperty "indexMaybe" prop_indexMaybe_Just_L - , testProperty "indexMaybe" prop_indexMaybe_Nothing_P - , testProperty "indexMaybe" prop_indexMaybe_Nothing_L - , testProperty "elemIndex" prop_elemIndex - , testProperty "elemIndices" prop_elemIndices - , testProperty "count/elemIndices" prop_count - , testProperty "findIndex" prop_findIndex - , testProperty "findIndexEnd" prop_findIndexEnd - , testProperty "findIndices" prop_findIndicies - , testProperty "find" prop_find - , testProperty "find/findIndex" prop_find_findIndex - , testProperty "elem" prop_elem - , testProperty "notElem" prop_notElem - , testProperty "elem/notElem" prop_elem_notelem --- , testProperty "filterByte 1" prop_filterByte --- , testProperty "filterByte 2" prop_filterByte2 --- , testProperty "filterNotByte 1" prop_filterNotByte --- , testProperty "filterNotByte 2" prop_filterNotByte2 - , testProperty "isPrefixOf" prop_isPrefixOf - , testProperty "isSuffixOf" prop_isSuffixOf - , testProperty "stripPrefix" prop_stripPrefix - , testProperty "stripSuffix" prop_stripSuffix - , testProperty "concatMap" prop_concatMap - , testProperty "isSpace" prop_isSpaceWord8 - ] - -findIndexEnd :: (a -> Bool) -> [a] -> Maybe Int -findIndexEnd p = go . findIndices p - where - go [] = Nothing - go (k:[]) = Just k - go (k:ks) = go ks - -elemIndexEnd :: Eq a => a -> [a] -> Maybe Int -elemIndexEnd = findIndexEnd . (==) +{-# LANGUAGE AllowAmbiguousTypes #-} +-- We need @AllowAmbiguousTypes@ in order to be able to use @TypeApplications@ +-- to disambiguate the desired instance of class methods whose instance cannot +-- be inferred from the caller's context. We would otherwise have to use +-- proxy arguments. Here the 'RdInt' class methods used to generate tests for +-- all the various 'readInt' types require explicit type applications. + +module Properties (testSuite) where + +import Prelude hiding (head, tail) +import Foreign.C.String (withCString) +import Foreign.Storable +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import GHC.Ptr +import Test.Tasty.QuickCheck +import Control.Applicative +import Control.Monad +import Control.Concurrent +import Control.Exception +import System.Posix.Internals (c_unlink) + +import qualified Data.List as List +import Data.Char +import Data.Word +import Data.Maybe +import Data.Either (isLeft) +import Data.Bits (finiteBitSize, bit) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Semigroup +import GHC.Exts (Int(..), newPinnedByteArray#, unsafeFreezeByteArray#) +import GHC.ST (ST(..), runST) + +import Text.Printf +import Data.String + +import System.Environment +import System.IO + +import Data.ByteString.Lazy (ByteString(..), pack , unpack) +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.Internal (ByteString(..)) + +import qualified Data.ByteString as P +import qualified Data.ByteString.Internal as P +import qualified Data.ByteString.Unsafe as P +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Short as Short + +import qualified Data.ByteString.Lazy.Char8 as LC +import qualified Data.ByteString.Lazy.Char8 as D + +import qualified Data.ByteString.Lazy.Internal as L + +import QuickCheckUtils +import Test.Tasty +import Test.Tasty.QuickCheck + +import qualified Properties.ShortByteString as PropSBS +import qualified Properties.ByteString as PropBS +import qualified Properties.ByteStringChar8 as PropBS8 +import qualified Properties.ByteStringLazy as PropBL +import qualified Properties.ByteStringLazyChar8 as PropBL8 + +prop_unsafeIndexBB xs = + not (null xs) ==> + forAll indices $ \i -> (xs !! i) == P.pack xs `P.unsafeIndex` i + where indices = choose (0, length xs -1) + +prop_bijectionBB (Char8 c) = (P.w2c . P.c2w) c == id c +prop_bijectionBB' w = (P.c2w . P.w2c) w == id w + +prop_unsafeHead xs = not (P.null xs) ==> P.head xs === P.unsafeHead xs +prop_unsafeTail xs = not (P.null xs) ==> P.tail xs === P.unsafeTail xs +prop_unsafeLast xs = not (P.null xs) ==> P.last xs === P.unsafeLast xs +prop_unsafeInit xs = not (P.null xs) ==> P.init xs === P.unsafeInit xs + +prop_lines_empty_invariant = + True === case LC.lines (LC.pack "\nfoo\n") of + Empty : _ -> True + _ -> False + +prop_lines_lazy = + take 2 (LC.lines (LC.append (LC.pack "a\nb\n") undefined)) === [LC.pack "a", LC.pack "b"] + +prop_lines_lazy2 = + c === case LC.lines (Chunk c undefined) of + Chunk c _ : _ -> c + _ -> P.empty + where + c = C.pack "etc..." + +prop_lines_lazy3 = + c === case LC.lines d of + Chunk c _ : _ -> c + _ -> P.empty + where + c = C.pack "etc..." + d = Chunk c d + +prop_strip x = C.strip x == (C.dropSpace . C.reverse . C.dropSpace . C.reverse) x + +class (Bounded a, Integral a, Show a) => RdInt a where + rdIntC :: C.ByteString -> Maybe (a, C.ByteString) + rdIntD :: D.ByteString -> Maybe (a, D.ByteString) + +instance RdInt Int where { rdIntC = C.readInt; rdIntD = D.readInt } +instance RdInt Int8 where { rdIntC = C.readInt8; rdIntD = D.readInt8 } +instance RdInt Int16 where { rdIntC = C.readInt16; rdIntD = D.readInt16 } +instance RdInt Int32 where { rdIntC = C.readInt32; rdIntD = D.readInt32 } +instance RdInt Int64 where { rdIntC = C.readInt64; rdIntD = D.readInt64 } +-- +instance RdInt Word where { rdIntC = C.readWord; rdIntD = D.readWord } +instance RdInt Word8 where { rdIntC = C.readWord8; rdIntD = D.readWord8 } +instance RdInt Word16 where { rdIntC = C.readWord16; rdIntD = D.readWord16 } +instance RdInt Word32 where { rdIntC = C.readWord32; rdIntD = D.readWord32 } +instance RdInt Word64 where { rdIntC = C.readWord64; rdIntD = D.readWord64 } + +smax :: forall a. (Bounded a, Show a) => String +smax = show $ maxBound @a +smax1 :: forall a. (Bounded a, Integral a) => String +smax1 = show $ fromIntegral @a @Integer maxBound + 1 +smax10 :: forall a. (Bounded a, Integral a) => String +smax10 = show $ fromIntegral @a @Integer maxBound + 10 + +smin :: forall a. (Bounded a, Show a) => String +smin = show (minBound @a) +smin1 :: forall a. (Bounded a, Integral a) => String +smin1 = show $ fromIntegral @a @Integer minBound - 1 +smin10 :: forall a. (Bounded a, Integral a) => String +smin10 = show $ fromIntegral @a @Integer minBound - 10 + +-- Ensure that readWord64 and readInteger over lazy ByteStrings are not +-- excessively strict. +prop_readWordSafe = (fst . fromJust . D.readWord64) (Chunk (C.pack "1z") Empty) == 1 +prop_readWordUnsafe = (fst . fromJust . D.readWord64) (Chunk (C.pack "2z") undefined) == 2 +prop_readIntegerSafe = (fst . fromJust . D.readInteger) (Chunk (C.pack "1z") Empty) == 1 +prop_readIntegerUnsafe = (fst . fromJust . D.readInteger) (Chunk (C.pack "2z") undefined) == 2 +prop_readNaturalSafe = (fst . fromJust . D.readNatural) (Chunk (C.pack "1z") Empty) == 1 +prop_readNaturalUnsafe = (fst . fromJust . D.readNatural) (Chunk (C.pack "2z") undefined) == 2 +prop_readIntBoundsCC = rdWordBounds @Word + && rdWordBounds @Word8 + && rdWordBounds @Word16 + && rdWordBounds @Word32 + && rdWordBounds @Word64 + && rdIntBounds @Int + && rdIntBounds @Int8 + && rdIntBounds @Int16 + && rdIntBounds @Int32 + && rdIntBounds @Int64 + where + tailStr = " tail" + zeroStr = "000000000000000000000000000" + spack s = C.pack $ s ++ tailStr + spackPlus s = C.pack $ '+' : (s ++ tailStr) + spackMinus s = C.pack $ '-' : (s ++ tailStr) + spackLong s = C.pack $ s ++ zeroStr ++ tailStr + spackZeros s = case s of + '+':num -> C.pack $ '+' : zeroStr ++ num ++ tailStr + '-':num -> C.pack $ '-' : zeroStr ++ num ++ tailStr + num -> C.pack $ zeroStr ++ num ++ tailStr + good i = Just (i, C.pack tailStr) + -- + rdWordBounds :: forall a. RdInt a => Bool + rdWordBounds = + -- Upper bound + rdIntC @a (spack (smax @a)) == good maxBound + -- With leading zeros + && rdIntC @a (spackZeros (smax @a)) == good maxBound + -- Overflow in last digit + && rdIntC @a (spack (smax1 @a)) == Nothing + -- Overflow in 2nd-last digit + && rdIntC @a (spack (smax10 @a)) == Nothing + -- Trailing zeros + && rdIntC @a (spackLong (smax @a)) == Nothing + -- + rdIntBounds :: forall a. RdInt a => Bool + rdIntBounds = + rdWordBounds @a + -- Lower bound + && rdIntC @a (spack (smin @a)) == good minBound + -- With leading signs + && rdIntC @a (spackPlus (smax @a)) == good maxBound + && rdIntC @a (spackMinus (smax @a)) == good (negate maxBound) + -- With leading zeros + && rdIntC @a (spackZeros (smax @a)) == good maxBound + -- Underflow in last digit + && rdIntC @a (spack (smin1 @a)) == Nothing + -- Underflow in 2nd-last digit + && rdIntC @a (spack (smin10 @a)) == Nothing + -- Trailing zeros + && rdIntC @a (spackLong (smin @a)) == Nothing + +prop_readIntBoundsLC = rdWordBounds @Word + && rdWordBounds @Word8 + && rdWordBounds @Word16 + && rdWordBounds @Word32 + && rdWordBounds @Word64 + && rdIntBounds @Int + && rdIntBounds @Int8 + && rdIntBounds @Int16 + && rdIntBounds @Int32 + && rdIntBounds @Int64 + where + tailStr = " tail" + zeroStr = "000000000000000000000000000" + spack s = LC.pack $ s ++ tailStr + spackPlus s = LC.singleton '+' `D.append` LC.pack s `D.append` LC.pack tailStr + spackMinus s = LC.singleton '-' `D.append` LC.pack s `D.append` LC.pack tailStr + spackLong1 s = LC.pack s `D.append` LC.pack zeroStr `D.append` LC.pack tailStr + spackLong2 s = LC.pack (s ++ zeroStr) `D.append` LC.pack tailStr + spackZeros s = case s of + '+':num -> LC.pack ('+' : zeroStr) `D.append` LC.pack (num ++ tailStr) + '-':num -> LC.pack ('-' : zeroStr) `D.append` LC.pack (num ++ tailStr) + num -> LC.pack $ zeroStr ++ num ++ tailStr + good i = Just (i, LC.pack tailStr) + -- + rdWordBounds :: forall a. RdInt a => Bool + rdWordBounds = + -- Upper bound + rdIntD @a (spack (smax @a)) == good maxBound + -- With leading zeros + && rdIntD @a (spackZeros (smax @a)) == good maxBound + -- Overflow in last digit + && rdIntD @a (spack (smax1 @a)) == Nothing + -- Overflow in 2nd-last digit + && rdIntD @a (spack (smax10 @a)) == Nothing + -- Overflow across chunk boundary + && rdIntD @a (spackLong1 (smax @a)) == Nothing + -- Overflow within chunk + && rdIntD @a (spackLong2 (smax @a)) == Nothing + -- Sign with no digits + && rdIntD @a (LC.pack "+ foo") == Nothing + && rdIntD @a (LC.pack "-bar") == Nothing + -- + rdIntBounds :: forall a. RdInt a => Bool + rdIntBounds = + rdWordBounds @a + -- Lower bound + && rdIntD @a (spack (smin @a)) == good minBound + -- With leading signs + && rdIntD @a (spackPlus (smax @a)) == good maxBound + && rdIntD @a (spackMinus (smax @a)) == good (negate maxBound) + -- With leading zeros + && rdIntD @a (spackZeros (smin @a)) == good minBound + -- Overflow in last digit + && rdIntD @a (spack (smin1 @a)) == Nothing + -- Overflow in 2nd-last digit + && rdIntD @a (spack (smin10 @a)) == Nothing + -- Overflow across chunk boundary + && rdIntD @a (spackLong1 (smin @a)) == Nothing + -- Overflow within chunk + && rdIntD @a (spackLong2 (smin @a)) == Nothing + +------------------------------------------------------------------------ + +expectSizeOverflow :: a -> Property +expectSizeOverflow val = ioProperty $ do + isLeft <$> try @P.SizeOverflowException (evaluate val) + +prop_checkedAdd = forAll (vectorOf 2 nonNeg) $ \[x, y] -> if oflo x y + then expectSizeOverflow (P.checkedAdd "" x y) + else property $ P.checkedAdd "" x y == x + y + where nonNeg = choose (0, (maxBound @Int)) + oflo x y = toInteger x + toInteger y /= toInteger @Int (x + y) + +multCompl :: Int -> Gen Int +multCompl x = choose (0, fromInteger @Int maxc) + -- This choice creates products with magnitude roughly in the range + -- [0..5*(maxBound @Int)], which results in a roughly even split + -- between positive and negative overflowed Int results, while still + -- producing a fair number of non-overflowing products. + where maxc = toInteger (maxBound @Int) * 5 `quot` max 5 (abs $ toInteger x) + +prop_checkedMultiply = forAll genScale $ \scale -> + forAll (genVal scale) $ \x -> + forAll (multCompl x) $ \y -> if oflo x y + then expectSizeOverflow (P.checkedMultiply "" x y) + else property $ P.checkedMultiply "" x y == x * y + where genScale = choose (0, finiteBitSize @Int 0 - 1) + genVal scale = choose (0, bit scale - 1) + oflo x y = toInteger x * toInteger y /= toInteger @Int (x * y) + +prop_stimesOverflowBasic bs = forAll (multCompl len) $ \n -> + toInteger n * toInteger len > maxInt ==> expectSizeOverflow (stimes n bs) + where + maxInt = toInteger @Int (maxBound @Int) + len = P.length bs + +prop_stimesOverflowScary bs = + -- "Scary" because this test will cause heap corruption + -- (not just memory exhaustion) with the old stimes implementation. + n > 1 ==> expectSizeOverflow (stimes reps bs) + where + n = P.length bs + reps = maxBound @Word `quot` fromIntegral @Int @Word n + 1 + +prop_stimesOverflowEmpty = forAll (choose (0, maxBound @Word)) $ \n -> + stimes n mempty === mempty @P.ByteString + +concat32bitOverflow :: (Int -> a) -> ([a] -> a) -> Property +concat32bitOverflow replicateLike concatLike = let + intBits = finiteBitSize @Int 0 + largeBS = concatLike $ replicate (bit 14) $ replicateLike (bit 17) + in if intBits /= 32 + then label "skipped due to non-32-bit Int" True + else expectSizeOverflow largeBS + +prop_32bitOverflow_Strict_mconcat :: Property +prop_32bitOverflow_Strict_mconcat = + concat32bitOverflow (`P.replicate` 0) mconcat + +prop_32bitOverflow_Lazy_toStrict :: Property +prop_32bitOverflow_Lazy_toStrict = + concat32bitOverflow (`P.replicate` 0) (L.toStrict . L.fromChunks) + +prop_32bitOverflow_Short_mconcat :: Property +prop_32bitOverflow_Short_mconcat = + concat32bitOverflow makeShort mconcat + where makeShort n = Short.toShort $ P.replicate n 0 + + +------------------------------------------------------------------------ + +prop_packUptoLenBytes cs = + forAll (choose (0, length cs + 1)) $ \n -> + let (bs, cs') = P.packUptoLenBytes n cs + in P.length bs == min n (length cs) + && take n cs == P.unpack bs + && P.pack (take n cs) == bs + && drop n cs == cs' + +prop_packUptoLenChars (String8 cs) = + forAll (choose (0, length cs + 1)) $ \n -> + let (bs, cs') = P.packUptoLenChars n cs + in P.length bs == min n (length cs) + && take n cs == C.unpack bs + && C.pack (take n cs) == bs + && drop n cs == cs' + +prop_unpackAppendBytesLazy cs' = + forAll (sized $ \n -> resize (n * 10) arbitrary) $ \cs -> + forAll (choose (0, 2)) $ \n -> + P.unpackAppendBytesLazy (P.drop n $ P.pack cs) cs' == drop n cs ++ cs' +prop_unpackAppendCharsLazy (String8 cs') = + forAll (sized $ \n -> resize (n * 10) arbitrary) $ \(String8 cs) -> + forAll (choose (0, 2)) $ \n -> + P.unpackAppendCharsLazy (P.drop n $ C.pack cs) cs' == drop n cs ++ cs' + +prop_unpackAppendBytesStrict cs cs' = + forAll (choose (0, length cs)) $ \n -> + P.unpackAppendBytesStrict (P.drop n $ P.pack cs) cs' == drop n cs ++ cs' + +prop_unpackAppendCharsStrict (String8 cs) (String8 cs') = + forAll (choose (0, length cs)) $ \n -> + P.unpackAppendCharsStrict (P.drop n $ C.pack cs) cs' == drop n cs ++ cs' + +------------------------------------------------------------------------ +-- Unsafe functions + +-- Test unsafePackAddress +prop_unsafePackAddress (CByteString x) = ioProperty $ do + let (p,_,_) = P.toForeignPtr (x `P.snoc` 0) + y <- withForeignPtr p $ \(Ptr addr) -> + P.unsafePackAddress addr + return (y == x) + +-- Test unsafePackAddressLen +prop_unsafePackAddressLen x = ioProperty $ do + let i = P.length x + (p,_,_) = P.toForeignPtr (x `P.snoc` 0) + y <- withForeignPtr p $ \(Ptr addr) -> + P.unsafePackAddressLen i addr + return (y == x) + +prop_unsafeUseAsCString x = ioProperty $ do + let n = P.length x + y <- P.unsafeUseAsCString x $ \cstr -> + sequence [ do a <- peekElemOff cstr i + let b = x `P.index` i + return (a == fromIntegral b) + | i <- [0.. n-1] ] + return (and y) + +prop_unsafeUseAsCStringLen x = ioProperty $ do + let n = P.length x + y <- P.unsafeUseAsCStringLen x $ \(cstr,_) -> + sequence [ do a <- peekElemOff cstr i + let b = x `P.index` i + return (a == fromIntegral b) + | i <- [0.. n-1] ] + return (and y) + +prop_useAsCString x = ioProperty $ do + let n = P.length x + y <- P.useAsCString x $ \cstr -> + sequence [ do a <- peekElemOff cstr i + let b = x `P.index` i + return (a == fromIntegral b) + | i <- [0.. n-1] ] + return (and y) + +prop_packCString (CByteString x) = ioProperty $ do + y <- P.useAsCString x $ P.unsafePackCString + return (y == x) + +prop_packCString_safe (CByteString x) = ioProperty $ do + y <- P.useAsCString x $ P.packCString + return (y == x) + +prop_packCStringLen x = ioProperty $ do + y <- P.useAsCStringLen x $ P.unsafePackCStringLen + return (y == x && P.length y == P.length x) + +prop_packCStringLen_safe x = ioProperty $ do + y <- P.useAsCStringLen x $ P.packCStringLen + return (y == x && P.length y == P.length x) + +prop_packMallocCString (CByteString x) = ioProperty $ do + + let (fp,_,_) = P.toForeignPtr x + ptr <- mallocArray0 (P.length x) :: IO (Ptr Word8) + forM_ [0 .. P.length x] $ \n -> pokeElemOff ptr n 0 + withForeignPtr fp $ \qtr -> copyArray ptr qtr (P.length x) + y <- P.unsafePackMallocCString (castPtr ptr) + + let !z = y == x + free ptr `seq` return z + +prop_unsafeFinalize x = + P.length x > 0 ==> + ioProperty $ do + x <- P.unsafeFinalize x + return (x == ()) + +prop_packCStringFinaliser x = ioProperty $ do + y <- P.useAsCString x $ \cstr -> P.unsafePackCStringFinalizer (castPtr cstr) (P.length x) (return ()) + return (y == x) + +prop_fromForeignPtr x = (let (a,b,c) = (P.toForeignPtr x) + in P.fromForeignPtr a b c) == x + +------------------------------------------------------------------------ +-- IO + +prop_read_write_file_P x = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + P.writeFile fn x + y <- P.readFile fn + removeFile fn + return (x === y) + +prop_read_write_file_C x = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + C.writeFile fn x + y <- C.readFile fn + removeFile fn + return (x === y) + +prop_read_write_file_L x = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + L.writeFile fn x + y <- L.readFile fn + L.length y `seq` removeFile fn + return (x === y) + +prop_read_write_file_D x = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + D.writeFile fn x + y <- D.readFile fn + D.length y `seq` removeFile fn + return (x === y) + +------------------------------------------------------------------------ + +prop_append_file_P x y = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + P.writeFile fn x + P.appendFile fn y + z <- P.readFile fn + removeFile fn + return (z === x `P.append` y) + +prop_append_file_C x y = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + C.writeFile fn x + C.appendFile fn y + z <- C.readFile fn + removeFile fn + return (z === x `C.append` y) + +prop_append_file_L x y = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + L.writeFile fn x + L.appendFile fn y + z <- L.readFile fn + L.length y `seq` removeFile fn + return (z === x `L.append` y) + +prop_append_file_D x y = ioProperty $ do + (fn, h) <- openTempFile "." "prop-compiled.tmp" + hClose h + D.writeFile fn x + D.appendFile fn y + z <- D.readFile fn + D.length y `seq` removeFile fn + return (z === x `D.append` y) + +prop_packAddress = C.pack "this is a test" + == + C.pack "this is a test" + +prop_isSpaceWord8 w = isSpace c == P.isSpaceChar8 c + where c = chr (fromIntegral (w :: Word8)) + + +------------------------------------------------------------------------ +-- ByteString.Short +-- + +prop_short_pack_unpack xs = + (Short.unpack . Short.pack) xs == xs +prop_short_toShort_fromShort bs = + (Short.fromShort . Short.toShort) bs == bs + +prop_short_toShort_unpack bs = + (Short.unpack . Short.toShort) bs == P.unpack bs +prop_short_pack_fromShort xs = + (Short.fromShort . Short.pack) xs == P.pack xs + +prop_short_empty = + Short.empty == Short.toShort P.empty + && Short.empty == Short.pack [] + && Short.null (Short.toShort P.empty) + && Short.null (Short.pack []) + && Short.null Short.empty + +prop_short_null_toShort bs = + P.null bs == Short.null (Short.toShort bs) +prop_short_null_pack xs = + null xs == Short.null (Short.pack xs) + +prop_short_length_toShort bs = + P.length bs == Short.length (Short.toShort bs) +prop_short_length_pack xs = + length xs == Short.length (Short.pack xs) + +prop_short_index_pack xs = + all (\i -> Short.pack xs `Short.index` i == xs !! i) + [0 .. length xs - 1] +prop_short_index_toShort bs = + all (\i -> Short.toShort bs `Short.index` i == bs `P.index` i) + [0 .. P.length bs - 1] + +prop_short_eq xs ys = + (xs == ys) == (Short.pack xs == Short.pack ys) +prop_short_ord xs ys = + (xs `compare` ys) == (Short.pack xs `compare` Short.pack ys) + +prop_short_mappend_empty_empty = + Short.empty `mappend` Short.empty == Short.empty +prop_short_mappend_empty xs = + Short.empty `mappend` Short.pack xs == Short.pack xs + && Short.pack xs `mappend` Short.empty == Short.pack xs +prop_short_mappend xs ys = + (xs `mappend` ys) == Short.unpack (Short.pack xs `mappend` Short.pack ys) +prop_short_mconcat xss = + mconcat xss == Short.unpack (mconcat (map Short.pack xss)) + +prop_short_fromString s = + fromString s == Short.fromShort (fromString s) + +prop_short_show xs = + show (Short.pack xs) == show (map P.w2c xs) +prop_short_show' xs = + show (Short.pack xs) == show (P.pack xs) + +prop_short_read xs = + read (show (Short.pack xs)) == Short.pack xs + +prop_short_pinned :: NonNegative Int -> Property +prop_short_pinned (NonNegative (I# len#)) = runST $ ST $ \s -> + case newPinnedByteArray# len# s of + (# s', mba# #) -> case unsafeFreezeByteArray# mba# s' of + (# s'', ba# #) -> let sbs = Short.SBS ba# in + (# s'', sbs === Short.toShort (Short.fromShort sbs) #) + +short_tests = + [ testProperty "pack/unpack" prop_short_pack_unpack + , testProperty "toShort/fromShort" prop_short_toShort_fromShort + , testProperty "toShort/unpack" prop_short_toShort_unpack + , testProperty "pack/fromShort" prop_short_pack_fromShort + , testProperty "empty" prop_short_empty + , testProperty "null/toShort" prop_short_null_toShort + , testProperty "null/pack" prop_short_null_pack + , testProperty "length/toShort" prop_short_length_toShort + , testProperty "length/pack" prop_short_length_pack + , testProperty "index/pack" prop_short_index_pack + , testProperty "index/toShort" prop_short_index_toShort + , testProperty "Eq" prop_short_eq + , testProperty "Ord" prop_short_ord + , testProperty "mappend/empty/empty" prop_short_mappend_empty_empty + , testProperty "mappend/empty" prop_short_mappend_empty + , testProperty "mappend" prop_short_mappend + , testProperty "mconcat" prop_short_mconcat + , testProperty "fromString" prop_short_fromString + , testProperty "show" prop_short_show + , testProperty "show'" prop_short_show' + , testProperty "read" prop_short_read + , testProperty "pinned" prop_short_pinned + ] + +------------------------------------------------------------------------ +-- Strictness checks. + +explosiveTail :: L.ByteString -> L.ByteString +explosiveTail = (`L.append` error "Tail of this byte string is undefined!") + +------------------------------------------------------------------------ +-- The entry point + +testSuite :: TestTree +testSuite = testGroup "Properties" + [ testGroup "ShortByteString" PropSBS.tests + , testGroup "StrictWord8" PropBS.tests + , testGroup "StrictChar8" PropBS8.tests + , testGroup "LazyWord8" PropBL.tests + , testGroup "LazyChar8" PropBL8.tests + , testGroup "Overflow" overflow_tests + , testGroup "Misc" misc_tests + , testGroup "IO" io_tests + , testGroup "Short" short_tests + , testGroup "Strictness" strictness_checks + ] + +io_tests = + [ testProperty "readFile.writeFile" prop_read_write_file_P + , testProperty "readFile.writeFile" prop_read_write_file_C + , testProperty "readFile.writeFile" prop_read_write_file_L + , testProperty "readFile.writeFile" prop_read_write_file_D + + , testProperty "appendFile " prop_append_file_P + , testProperty "appendFile " prop_append_file_C + , testProperty "appendFile " prop_append_file_L + , testProperty "appendFile " prop_append_file_D + + , testProperty "packAddress " prop_packAddress + ] + +overflow_tests = + [ testProperty "checkedAdd" prop_checkedAdd + , testProperty "checkedMultiply" prop_checkedMultiply + , testProperty "StrictByteString stimes (basic)" prop_stimesOverflowBasic + , testProperty "StrictByteString stimes (scary)" prop_stimesOverflowScary + , testProperty "StrictByteString stimes (empty)" prop_stimesOverflowEmpty + , testProperty "StrictByteString mconcat" prop_32bitOverflow_Strict_mconcat + , testProperty "LazyByteString toStrict" prop_32bitOverflow_Lazy_toStrict + , testProperty "ShortByteString mconcat" prop_32bitOverflow_Short_mconcat + ] + +misc_tests = + [ testProperty "packUptoLenBytes" prop_packUptoLenBytes + , testProperty "packUptoLenChars" prop_packUptoLenChars + , testProperty "unpackAppendBytesLazy" prop_unpackAppendBytesLazy + , testProperty "unpackAppendCharsLazy" prop_unpackAppendCharsLazy + , testProperty "unpackAppendBytesStrict"prop_unpackAppendBytesStrict + , testProperty "unpackAppendCharsStrict"prop_unpackAppendCharsStrict + + , testProperty "unsafe pack address" prop_unsafePackAddress + , testProperty "unsafe pack address len"prop_unsafePackAddressLen + , testProperty "unsafeUseAsCString" prop_unsafeUseAsCString + , testProperty "unsafeUseAsCStringLen" prop_unsafeUseAsCStringLen + , testProperty "useAsCString" prop_useAsCString + , testProperty "packCString" prop_packCString + , testProperty "packCString safe" prop_packCString_safe + , testProperty "packCStringLen" prop_packCStringLen + , testProperty "packCStringLen safe" prop_packCStringLen_safe + , testProperty "packCStringFinaliser" prop_packCStringFinaliser + , testProperty "packMallocString" prop_packMallocCString + , testProperty "unsafeFinalise" prop_unsafeFinalize + , testProperty "fromForeignPtr" prop_fromForeignPtr + + , testProperty "w2c . c2w" prop_bijectionBB + , testProperty "c2w . w2c" prop_bijectionBB' + + , testProperty "unsafeHead" prop_unsafeHead + , testProperty "unsafeTail" prop_unsafeTail + , testProperty "unsafeLast" prop_unsafeLast + , testProperty "unsafeInit" prop_unsafeInit + , testProperty "unsafeIndex" prop_unsafeIndexBB + + , testProperty "lines_lazy" prop_lines_lazy + , testProperty "lines_lazy2" prop_lines_lazy2 + , testProperty "lines_lazy3" prop_lines_lazy3 + , testProperty "lines_invar" prop_lines_empty_invariant + , testProperty "strip" prop_strip + , testProperty "isSpace" prop_isSpaceWord8 + + , testProperty "readWordSafe" prop_readWordSafe + , testProperty "readWordUnsafe" prop_readWordUnsafe + , testProperty "readIntBoundsCC" prop_readIntBoundsCC + , testProperty "readIntBoundsLC" prop_readIntBoundsLC + , testProperty "readIntegerSafe" prop_readIntegerSafe + , testProperty "readIntegerUnsafe" prop_readIntegerUnsafe + , testProperty "readNaturalSafe" prop_readNaturalSafe + , testProperty "readNaturalUnsafe" prop_readNaturalUnsafe + ] + +strictness_checks = + [ testGroup "Lazy Word8" + [ testProperty "foldr is lazy" $ \ xs -> + List.genericTake (L.length xs) (L.foldr (:) [ ] (explosiveTail xs)) === L.unpack xs + , testProperty "foldr' is strict" $ expectFailure $ \ xs ys -> + List.genericTake (L.length xs) (L.foldr' (:) [ ] (explosiveTail (xs <> ys))) === L.unpack xs + , testProperty "foldr1 is lazy" $ \ xs -> L.length xs > 0 ==> + L.foldr1 const (explosiveTail (xs <> L.singleton 1)) === L.head xs + , testProperty "foldr1' is strict" $ expectFailure $ \ xs ys -> L.length xs > 0 ==> + L.foldr1' const (explosiveTail (xs <> L.singleton 1 <> ys)) === L.head xs + , testProperty "scanl is lazy" $ \ xs -> + L.take (L.length xs + 1) (L.scanl (+) 0 (explosiveTail (xs <> L.singleton 1))) === (L.pack . fmap (L.foldr (+) 0) . L.inits) xs + , testProperty "scanl1 is lazy" $ \ xs -> L.length xs > 0 ==> + L.take (L.length xs) (L.scanl1 (+) (explosiveTail (xs <> L.singleton 1))) === (L.pack . fmap (L.foldr1 (+)) . drop 1 . L.inits) xs + ] + , testGroup "Lazy Char" + [ testProperty "foldr is lazy" $ \ xs -> + List.genericTake (D.length xs) (D.foldr (:) [ ] (explosiveTail xs)) === D.unpack xs + , testProperty "foldr' is strict" $ expectFailure $ \ xs ys -> + List.genericTake (D.length xs) (D.foldr' (:) [ ] (explosiveTail (xs <> ys))) === D.unpack xs + , testProperty "foldr1 is lazy" $ \ xs -> D.length xs > 0 ==> + D.foldr1 const (explosiveTail (xs <> D.singleton 'x')) === D.head xs + , testProperty "foldr1' is strict" $ expectFailure $ \ xs ys -> D.length xs > 0 ==> + D.foldr1' const (explosiveTail (xs <> D.singleton 'x' <> ys)) === D.head xs + , testProperty "scanl is lazy" $ \ xs -> let char1 +. char2 = toEnum (fromEnum char1 + fromEnum char2) in + D.take (D.length xs + 1) (D.scanl (+.) '\NUL' (explosiveTail (xs <> D.singleton '\SOH'))) === (D.pack . fmap (D.foldr (+.) '\NUL') . D.inits) xs + , testProperty "scanl1 is lazy" $ \ xs -> D.length xs > 0 ==> let char1 +. char2 = toEnum (fromEnum char1 + fromEnum char2) in + D.take (D.length xs) (D.scanl1 (+.) (explosiveTail (xs <> D.singleton '\SOH'))) === (D.pack . fmap (D.foldr1 (+.)) . drop 1 . D.inits) xs + , testProperty "unlines is lazy" $ \ xs -> D.take (D.length xs + 1) (D.unlines (xs : error "Tail of this list is undefined!")) === xs `D.snoc` '\n' + ] + ] removeFile :: String -> IO () removeFile fn = void $ withCString fn c_unlink diff --git a/tests/Properties/ByteString.hs b/tests/Properties/ByteString.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ByteString.hs @@ -0,0 +1,830 @@ +-- | +-- Module : Properties.ByteString +-- Copyright : (c) Andrew Lelechenko 2021 +-- License : BSD-style + +{-# LANGUAGE CPP #-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ViewPatterns #-} +-- We need @AllowAmbiguousTypes@ in order to be able to use @TypeApplications@ +-- to disambiguate the desired instance of class methods whose instance cannot +-- be inferred from the caller's context. We would otherwise have to use +-- proxy arguments. Here the 'RdInt' class methods used to generate tests for +-- all the various 'readInt' types require explicit type applications. + +-- We are happy to sacrifice optimizations in exchange for faster compilation, +-- but need to test rewrite rules. As one can check using -ddump-rule-firings, +-- rewrite rules do not fire in -O0 mode, so we use -O1, but disable almost all +-- optimizations. It roughly halves compilation time. +{-# OPTIONS_GHC -O1 -fenable-rewrite-rules + -fmax-simplifier-iterations=1 -fsimplifier-phases=0 + -fno-call-arity -fno-case-merge -fno-cmm-elim-common-blocks -fno-cmm-sink + -fno-cpr-anal -fno-cse -fno-do-eta-reduction -fno-float-in -fno-full-laziness + -fno-loopification -fno-specialise -fno-strictness #-} + +-- BYTESTRING_CHAR8 and BYTESTRING_LAZY are defined in +-- Properties.ByteString{Char8,Lazy,LazyChar8}, which include this file. +#ifndef BYTESTRING_CHAR8 + +#if defined(BYTESTRING_SHORT) +module Properties.ShortByteString (tests) where +import qualified Data.ByteString.Short as B +import qualified Data.ByteString.Short.Internal as B +#define BYTESTRING_TYPE B.ShortByteString +#elif !(defined BYTESTRING_LAZY) +module Properties.ByteString (tests) where +#define BYTESTRING_TYPE B.ByteString +import qualified Data.ByteString as B +import GHC.IO.Encoding +#else +module Properties.ByteStringLazy (tests) where +#define BYTESTRING_TYPE B.ByteString +import qualified Data.ByteString.Lazy as B +#endif + +#else + +#ifndef BYTESTRING_LAZY +module Properties.ByteStringChar8 (tests) where +import qualified Data.ByteString.Char8 as B +#define BYTESTRING_TYPE B.ByteString +#else +module Properties.ByteStringLazyChar8 (tests) where +import qualified Data.ByteString.Lazy.Char8 as B +#define BYTESTRING_TYPE B.ByteString +#endif + +import Data.Int +import Numeric.Natural (Natural) + +import Text.Read + +#endif + +import Prelude hiding (head, tail) +import Control.Arrow +import Data.Char +import Data.Data (toConstr, showConstr, Data) +import Data.Foldable +import Data.Generics.Text (gread, gshow) +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE +import Data.Semigroup +import Data.String +import Data.Tuple +import Data.Word +import Test.Tasty +import Test.Tasty.QuickCheck +import QuickCheckUtils + +#ifdef BYTESTRING_LAZY +import Data.Int +#endif + +#ifndef BYTESTRING_CHAR8 +toElem :: Word8 -> Word8 +toElem = id +#else +toElem :: Char8 -> Char +toElem (Char8 c) = c + +class (Integral a, Show a) => RdInt a where + bread :: BYTESTRING_TYPE -> Maybe (a, BYTESTRING_TYPE) + sread :: String -> Maybe (a, String) + +instance RdInt Int where { bread = B.readInt; sread = readInt } +instance RdInt Int8 where { bread = B.readInt8; sread = readInt8 } +instance RdInt Int16 where { bread = B.readInt16; sread = readInt16 } +instance RdInt Int32 where { bread = B.readInt32; sread = readInt32 } +instance RdInt Int64 where { bread = B.readInt64; sread = readInt64 } +-- +instance RdInt Word where { bread = B.readWord; sread = readWord } +instance RdInt Word8 where { bread = B.readWord8; sread = readWord8 } +instance RdInt Word16 where { bread = B.readWord16; sread = readWord16 } +instance RdInt Word32 where { bread = B.readWord32; sread = readWord32 } +instance RdInt Word64 where { bread = B.readWord64; sread = readWord64 } +-- +instance RdInt Integer where { bread = B.readInteger; sread = readInteger } +instance RdInt Natural where { bread = B.readNatural; sread = readNatural } + +instance Arbitrary Natural where + arbitrary = i2n <$> arbitrary + where i2n :: Integer -> Natural + i2n i | i >= 0 = fromIntegral i + | otherwise = fromIntegral $ negate i + +testRdInt :: forall a. (Arbitrary a, RdInt a) => String -> TestTree +testRdInt s = testGroup s $ + [ testProperty "from string" $ int64OK $ \value prefix suffix -> + let si = show @a value + b = prefix <> B.pack si <> suffix + in fmap (second B.unpack) (bread @a b) + === sread @a (B.unpack prefix ++ si ++ B.unpack suffix) + , testProperty "from number" $ int64OK $ \n -> + bread @a (B.pack (show n)) === Just (n, B.empty) + ] +#endif + +intToIndexTy :: Int -> IndexTy +#ifdef BYTESTRING_LAZY +type IndexTy = Int64 +intToIndexTy = fromIntegral @Int @Int64 +#else +type IndexTy = Int +intToIndexTy = id +#endif + +tests :: [TestTree] +tests = + [ testProperty "pack . unpack" $ + \x -> x === B.pack (B.unpack x) + , testProperty "unpack . pack" $ + \(map toElem -> xs) -> xs === B.unpack (B.pack xs) + , testProperty "read . show" $ + \x -> (x :: BYTESTRING_TYPE) === read (show x) +#ifndef BYTESTRING_SHORT + , testProperty "fromStrict . toStrict" $ + \x -> B.fromStrict (B.toStrict x) === x + , testProperty "toStrict . fromStrict" $ + \x -> B.toStrict (B.fromStrict x) === x +#endif +#if !defined(BYTESTRING_LAZY) && !defined(BYTESTRING_CHAR8) && !defined(BYTESTRING_SHORT) + , testProperty "toFilePath >>= fromFilePath" $ + \x -> ioProperty $ do + r <- B.toFilePath x >>= B.fromFilePath + pure (r === x) + , testProperty "fromFilePath >>= toFilePath" $ ioProperty $ do + let prop x = ioProperty $ do + r <- B.fromFilePath x >>= B.toFilePath + pure (r === x) + -- Normally getFileSystemEncoding returns a Unicode encoding, + -- but if it is ASCII, we should not generate Unicode filenames. + enc <- getFileSystemEncoding + pure $ case textEncodingName enc of + "ASCII" -> property (prop . getASCIIString) + "ANSI_X3.4-1968" -> property (prop . getASCIIString) + _ -> property prop +#endif + + , testProperty "==" $ + \x y -> (x == y) === (B.unpack x == B.unpack y) + , testProperty "== refl" $ + \x -> (x :: BYTESTRING_TYPE) == x + , testProperty "== symm" $ + \x y -> ((x :: BYTESTRING_TYPE) == y) === (y == x) + , testProperty "== pack unpack" $ + \x -> x == B.pack (B.unpack x) +#ifndef BYTESTRING_SHORT + , testProperty "== copy" $ + \x -> x == B.copy x +#endif + + , testProperty "compare" $ + \x y -> compare x y === compare (B.unpack x) (B.unpack y) + , testProperty "compare EQ" $ + \x -> compare (x :: BYTESTRING_TYPE) x == EQ + , testProperty "compare GT" $ + \x (toElem -> c) -> compare (B.snoc x c) x == GT + , testProperty "compare LT" $ + \x (toElem -> c) -> compare x (B.snoc x c) == LT + , testProperty "compare GT empty" $ + \x -> not (B.null x) ==> compare x B.empty == GT + , testProperty "compare LT empty" $ + \x -> not (B.null x) ==> compare B.empty x == LT + , testProperty "compare GT concat" $ + \x y -> not (B.null y) ==> compare (x <> y) x == GT + , testProperty "compare char" $ + \(toElem -> c) (toElem -> d) -> compare c d == compare (B.singleton c) (B.singleton d) +#ifndef BYTESTRING_CHAR8 + , testProperty "compare unsigned" $ once $ + compare (B.singleton 255) (B.singleton 127) == GT +#endif + + , testProperty "null" $ + \x -> B.null x === null (B.unpack x) + , testProperty "empty 0" $ once $ + B.length B.empty === 0 + , testProperty "empty []" $ once $ + B.unpack B.empty === [] + , testProperty "mempty 0" $ once $ + B.length mempty === 0 + , testProperty "mempty []" $ once $ + B.unpack mempty === [] + + , testProperty "concat" $ + \(Sqrt xs) -> B.unpack (B.concat xs) === concat (map B.unpack xs) + , testProperty "concat [x,x]" $ + \x -> B.unpack (B.concat [x, x]) === concat [B.unpack x, B.unpack x] + , testProperty "concat [x,[]]" $ + \x -> B.unpack (B.concat [x, B.empty]) === concat [B.unpack x, []] + , testProperty "mconcat" $ + \(Sqrt xs) -> B.unpack (mconcat xs) === mconcat (map B.unpack xs) + , testProperty "mconcat [x,x]" $ + \x -> B.unpack (mconcat [x, x]) === mconcat [B.unpack x, B.unpack x] + , testProperty "mconcat [x,[]]" $ + \x -> B.unpack (mconcat [x, B.empty]) === mconcat [B.unpack x, []] + + , testProperty "null" $ + \x -> B.null x === null (B.unpack x) + , testProperty "reverse" $ + \x -> B.unpack (B.reverse x) === reverse (B.unpack x) +#ifndef BYTESTRING_SHORT + , testProperty "transpose" $ + \xs -> map B.unpack (B.transpose xs) === List.transpose (map B.unpack xs) + , testProperty "group" $ + \x -> map B.unpack (B.group x) === List.group (B.unpack x) + , testProperty "groupBy" $ + \f x -> map B.unpack (B.groupBy f x) === List.groupBy f (B.unpack x) + , testProperty "groupBy ==" $ + \x -> map B.unpack (B.groupBy (==) x) === List.groupBy (==) (B.unpack x) + , testProperty "groupBy /=" $ + \x -> map B.unpack (B.groupBy (/=) x) === List.groupBy (/=) (B.unpack x) + , testProperty "inits" $ + \x -> map B.unpack (B.inits x) === List.inits (B.unpack x) + , testProperty "tails" $ + \x -> map B.unpack (B.tails x) === List.tails (B.unpack x) + , testProperty "initsNE" $ + \x -> NE.map B.unpack (B.initsNE x) === NE.inits (B.unpack x) + , testProperty "tailsNE" $ + \x -> NE.map B.unpack (B.tailsNE x) === NE.tails (B.unpack x) +#endif + , testProperty "all" $ + \f x -> B.all f x === all f (B.unpack x) + , testProperty "all ==" $ + \(toElem -> c) x -> B.all (== c) x === all (== c) (B.unpack x) + , testProperty "any" $ + \f x -> B.any f x === any f (B.unpack x) + , testProperty "any ==" $ + \(toElem -> c) x -> B.any (== c) x === any (== c) (B.unpack x) + , testProperty "append" $ + \x y -> B.unpack (B.append x y) === B.unpack x ++ B.unpack y + , testProperty "mappend" $ + \x y -> B.unpack (mappend x y) === B.unpack x `mappend` B.unpack y + , testProperty "<>" $ + \x y -> B.unpack (x <> y) === B.unpack x <> B.unpack y + , testProperty "stimes" $ + \(Sqrt (NonNegative n)) (Sqrt x) -> stimes (n :: Int) (x :: BYTESTRING_TYPE) === stimesMonoid n x + + , testProperty "break" $ + \f x -> (B.unpack *** B.unpack) (B.break f x) === break f (B.unpack x) + , testProperty "break ==" $ + \(toElem -> c) x -> (B.unpack *** B.unpack) (B.break (== c) x) === break (== c) (B.unpack x) + , testProperty "break /=" $ + \(toElem -> c) x -> (B.unpack *** B.unpack) (B.break (/= c) x) === break (/= c) (B.unpack x) + , testProperty "break span" $ + \f x -> B.break f x === B.span (not . f) x + , testProperty "breakEnd" $ + \f x -> B.breakEnd f x === swap ((B.reverse *** B.reverse) (B.break f (B.reverse x))) + , testProperty "breakEnd" $ + \f x -> B.breakEnd f x === B.spanEnd (not . f) x + +#ifndef BYTESTRING_LAZY + , testProperty "break breakSubstring" $ + \(toElem -> c) x -> B.break (== c) x === B.breakSubstring (B.singleton c) x + , testProperty "breakSubstring" $ + \x y -> not (B.null x) ==> B.null (snd (B.breakSubstring x y)) === not (B.isInfixOf x y) + , testProperty "breakSubstring empty" $ + \x -> B.breakSubstring B.empty x === (B.empty, x) +#endif +#ifdef BYTESTRING_CHAR8 + , testProperty "break isSpace" $ + \x -> (B.unpack *** B.unpack) (B.break isSpace x) === break isSpace (B.unpack x) +#endif + +#ifndef BYTESTRING_SHORT + , testProperty "concatMap" $ + \f x -> B.unpack (B.concatMap f x) === concatMap (B.unpack . f) (B.unpack x) + , testProperty "concatMap singleton" $ + \x -> B.unpack (B.concatMap B.singleton x) === concatMap (: []) (B.unpack x) +#endif + + , testProperty "singleton" $ + \(toElem -> c) -> B.unpack (B.singleton c) === [c] + , testProperty "cons" $ + \(toElem -> c) x -> B.unpack (B.cons c x) === c : B.unpack x + , testProperty "cons []" $ + \(toElem -> c) -> B.unpack (B.cons c B.empty) === [c] + , testProperty "uncons" $ + \x -> fmap (second B.unpack) (B.uncons x) === List.uncons (B.unpack x) + , testProperty "snoc" $ + \(toElem -> c) x -> B.unpack (B.snoc x c) === B.unpack x ++ [c] + , testProperty "snoc []" $ + \(toElem -> c) -> B.unpack (B.snoc B.empty c) === [c] + , testProperty "unsnoc" $ + \x -> fmap (first B.unpack) (B.unsnoc x) === unsnoc (B.unpack x) +#ifdef BYTESTRING_LAZY + , testProperty "cons'" $ + \(toElem -> c) x -> B.unpack (B.cons' c x) === c : B.unpack x +#endif + + , testProperty "drop" $ + \(intToIndexTy -> n) x -> B.unpack (B.drop n x) === List.genericDrop n (B.unpack x) + , testProperty "drop 10" $ + \x -> let n = 10 in B.unpack (B.drop n x) === List.genericDrop n (B.unpack x) + , testProperty "drop 2^31" $ + \x -> let n = 2^31 in B.unpack (B.drop n x) === List.genericDrop n (B.unpack x) + , testProperty "dropWhile" $ + \f x -> B.unpack (B.dropWhile f x) === dropWhile f (B.unpack x) + , testProperty "dropWhile ==" $ + \(toElem -> c) x -> B.unpack (B.dropWhile (== c) x) === dropWhile (== c) (B.unpack x) + , testProperty "dropWhile /=" $ + \(toElem -> c) x -> B.unpack (B.dropWhile (/= c) x) === dropWhile (/= c) (B.unpack x) +#ifdef BYTESTRING_CHAR8 + , testProperty "dropWhile isSpace" $ + \x -> B.unpack (B.dropWhile isSpace x) === dropWhile isSpace (B.unpack x) +#endif + + , testProperty "take" $ + \(intToIndexTy -> n) x -> B.unpack (B.take n x) === List.genericTake n (B.unpack x) + , testProperty "take 10" $ + \x -> let n = 10 in B.unpack (B.take n x) === List.genericTake n (B.unpack x) + , testProperty "take 2^31" $ + \x -> let n = 2^31 in B.unpack (B.take n x) === List.genericTake n (B.unpack x) + , testProperty "takeWhile" $ + \f x -> B.unpack (B.takeWhile f x) === takeWhile f (B.unpack x) + , testProperty "takeWhile ==" $ + \(toElem -> c) x -> B.unpack (B.takeWhile (== c) x) === takeWhile (== c) (B.unpack x) + , testProperty "takeWhile /=" $ + \(toElem -> c) x -> B.unpack (B.takeWhile (/= c) x) === takeWhile (/= c) (B.unpack x) +#ifdef BYTESTRING_CHAR8 + , testProperty "takeWhile isSpace" $ + \x -> B.unpack (B.takeWhile isSpace x) === takeWhile isSpace (B.unpack x) +#endif + + , testProperty "dropEnd" $ + \(intToIndexTy -> n) x -> B.dropEnd n x === B.take (B.length x - n) x + , testProperty "dropWhileEnd" $ + \f x -> B.dropWhileEnd f x === B.reverse (B.dropWhile f (B.reverse x)) + , testProperty "takeEnd" $ + \(intToIndexTy -> n) x -> B.takeEnd n x === B.drop (B.length x - n) x + , testProperty "takeWhileEnd" $ + \f x -> B.takeWhileEnd f x === B.reverse (B.takeWhile f (B.reverse x)) + +#ifdef BYTESTRING_LAZY + , testProperty "fromChunks . toChunks" $ + \x -> B.fromChunks (B.toChunks x) === x + , testProperty "toChunks . fromChunks" $ + \xs -> B.toChunks (B.fromChunks xs) === filter (/= mempty) xs + , testProperty "append lazy" $ + \(toElem -> c) -> B.head (B.singleton c <> tooStrictErr) === c + , testProperty "compareLength 1" $ + \x -> B.compareLength x (B.length x) === EQ + , testProperty "compareLength 2" $ + \x (toElem -> c) -> B.compareLength (B.snoc x c) (B.length x) === GT + , testProperty "compareLength 3" $ + \x -> B.compareLength x (B.length x + 1) === LT + , testProperty "compareLength 4" $ + \x (toElem -> c) -> B.compareLength (B.snoc x c <> undefined) (B.length x) === GT + , testProperty "compareLength 5" $ + \x (intToIndexTy -> n) -> B.compareLength x n === compare (B.length x) n + , testProperty "dropEnd lazy" $ + \(toElem -> c) -> B.take 1 (B.dropEnd 1 (B.singleton c <> B.singleton c <> B.singleton c <> tooStrictErr)) === B.singleton c + , testProperty "dropWhileEnd lazy" $ + \(toElem -> c) -> B.take 1 (B.dropWhileEnd (const False) (B.singleton c <> tooStrictErr)) === B.singleton c + , testProperty "breakEnd lazy" $ + \(toElem -> c) -> B.take 1 (fst $ B.breakEnd (const True) (B.singleton c <> tooStrictErr)) === B.singleton c + , testProperty "spanEnd lazy" $ + \(toElem -> c) -> B.take 1 (fst $ B.spanEnd (const False) (B.singleton c <> tooStrictErr)) === B.singleton c +#endif + + , testProperty "length" $ + \x -> B.length x === fromIntegral (length (B.unpack x)) + , testProperty "count" $ + \(toElem -> c) x -> B.count c x === fromIntegral (length (List.elemIndices c (B.unpack x))) + -- for long strings, the multiplier is non-round (and not power of 2) + -- to ensure non-trivial prefix or suffix of the string is handled outside any possible SIMD-based loop, + -- which typically handles chunks of 16 or 32 or 64 etc bytes. + , testProperty "count (long strings)" $ + \(toElem -> c) x (Positive n) -> B.count c x * fromIntegral n === B.count c (B.concat $ replicate n x) + , testProperty "filter" $ + \f x -> B.unpack (B.filter f x) === filter f (B.unpack x) + , testProperty "filter compose" $ + \f g x -> B.filter f (B.filter g x) === B.filter (\c -> f c && g c) x + , testProperty "filter ==" $ + \(toElem -> c) x -> B.unpack (B.filter (== c) x) === filter (== c) (B.unpack x) + , testProperty "filter /=" $ + \(toElem -> c) x -> B.unpack (B.filter (/= c) x) === filter (/= c) (B.unpack x) + , testProperty "partition" $ + \f x -> (B.unpack *** B.unpack) (B.partition f x) === List.partition f (B.unpack x) + + , testProperty "find" $ + \f x -> B.find f x === find f (B.unpack x) + , testProperty "findIndex" $ + \f x -> B.findIndex f x === fmap fromIntegral (List.findIndex f (B.unpack x)) +#ifndef BYTESTRING_SHORT + , testProperty "findIndexEnd" $ + \f x -> B.findIndexEnd f x === fmap fromIntegral (findIndexEnd f (B.unpack x)) +#endif + , testProperty "findIndices" $ + \f x -> B.findIndices f x === fmap fromIntegral (List.findIndices f (B.unpack x)) + , testProperty "findIndices ==" $ + \(toElem -> c) x -> B.findIndices (== c) x === fmap fromIntegral (List.findIndices (== c) (B.unpack x)) + + , testProperty "elem" $ + \(toElem -> c) x -> B.elem c x === elem c (B.unpack x) +#ifndef BYTESTRING_SHORT + , testProperty "notElem" $ + \(toElem -> c) x -> B.notElem c x === notElem c (B.unpack x) +#endif + , testProperty "elemIndex" $ + \(toElem -> c) x -> B.elemIndex c x === fmap fromIntegral (List.elemIndex c (B.unpack x)) +#ifndef BYTESTRING_SHORT + , testProperty "elemIndexEnd" $ + \(toElem -> c) x -> B.elemIndexEnd c x === fmap fromIntegral (elemIndexEnd c (B.unpack x)) +#endif + , testProperty "elemIndices" $ + \(toElem -> c) x -> B.elemIndices c x === fmap fromIntegral (List.elemIndices c (B.unpack x)) + + , testProperty "isPrefixOf" $ + \x y -> B.isPrefixOf x y === List.isPrefixOf (B.unpack x) (B.unpack y) + , testProperty "stripPrefix" $ + \x y -> fmap B.unpack (B.stripPrefix x y) === List.stripPrefix (B.unpack x) (B.unpack y) + , testProperty "isSuffixOf" $ + \x y -> B.isSuffixOf x y === List.isSuffixOf (B.unpack x) (B.unpack y) + , testProperty "stripSuffix" $ + \x y -> fmap B.unpack (B.stripSuffix x y) === stripSuffix (B.unpack x) (B.unpack y) +#ifndef BYTESTRING_LAZY + , testProperty "isInfixOf" $ + \x y -> B.isInfixOf x y === List.isInfixOf (B.unpack x) (B.unpack y) +#endif + + , testProperty "map" $ + \f x -> B.unpack (B.map (toElem . f) x) === map (toElem . f) (B.unpack x) + , testProperty "map compose" $ + \f g x -> B.map (toElem . f) (B.map (toElem . g) x) === B.map (toElem . f . toElem . g) x + , testProperty "replicate" $ + \n (toElem -> c) -> B.unpack (B.replicate (fromIntegral n) c) === replicate n c + , testProperty "replicate 0" $ + \(toElem -> c) -> B.unpack (B.replicate 0 c) === replicate 0 c + + , testProperty "span" $ + \f x -> (B.unpack *** B.unpack) (B.span f x) === span f (B.unpack x) + , testProperty "span ==" $ + \(toElem -> c) x -> (B.unpack *** B.unpack) (B.span (== c) x) === span (== c) (B.unpack x) + , testProperty "span /=" $ + \(toElem -> c) x -> (B.unpack *** B.unpack) (B.span (/= c) x) === span (/= c) (B.unpack x) + , testProperty "spanEnd" $ + \f x -> B.spanEnd f x === swap ((B.reverse *** B.reverse) (B.span f (B.reverse x))) + , testProperty "split" $ + \(toElem -> c) x -> map B.unpack (B.split c x) === split c (B.unpack x) + , testProperty "split empty" $ + \(toElem -> c) -> B.split c B.empty === [] + , testProperty "splitWith" $ + \f x -> map B.unpack (B.splitWith f x) === splitWith f (B.unpack x) + , testProperty "splitWith split" $ + \(toElem -> c) x -> B.splitWith (== c) x === B.split c x + , testProperty "splitWith empty" $ + \f -> B.splitWith f B.empty === [] + , testProperty "splitWith length" $ + \f x -> let splits = B.splitWith f x; l1 = fromIntegral (length splits); l2 = B.length (B.filter f x) in + (l1 == l2 || l1 == l2 + 1) && sum (map B.length splits) + l2 == B.length x + + , testProperty "splitAt" $ + \(intToIndexTy -> n) x -> (B.unpack *** B.unpack) (B.splitAt n x) + === List.genericSplitAt n (B.unpack x) + , testProperty "splitAt 10" $ + \x -> let n = 10 in (B.unpack *** B.unpack) (B.splitAt n x) === List.genericSplitAt n (B.unpack x) + , testProperty "splitAt (2^31)" $ + \x -> let n = 2^31 in (B.unpack *** B.unpack) (B.splitAt n x) === List.genericSplitAt n (B.unpack x) + + , testProperty "head" $ + \x -> case B.unpack x of + [] -> property True + hd : _ -> B.head x === hd + , testProperty "last" $ + \x -> not (B.null x) ==> B.last x === last (B.unpack x) + , testProperty "tail" $ + \x -> case B.unpack x of + [] -> property True + _ : tl -> B.unpack (B.tail x) === tl + , testProperty "tail length" $ + \x -> not (B.null x) ==> B.length x === 1 + B.length (B.tail x) + , testProperty "init" $ + \x -> not (B.null x) ==> B.unpack (B.init x) === init (B.unpack x) + , testProperty "init length" $ + \x -> not (B.null x) ==> B.length x === 1 + B.length (B.init x) +#ifndef BYTESTRING_SHORT + , testProperty "maximum" $ + \x -> not (B.null x) ==> B.maximum x === maximum (B.unpack x) + , testProperty "minimum" $ + \x -> not (B.null x) ==> B.minimum x === minimum (B.unpack x) +#endif + + , testProperty "foldl" $ + \f (toElem -> c) x -> B.foldl ((toElem .) . f) c x === foldl ((toElem .) . f) c (B.unpack x) + , testProperty "foldl'" $ + \f (toElem -> c) x -> B.foldl' ((toElem .) . f) c x === foldl' ((toElem .) . f) c (B.unpack x) + , testProperty "foldr" $ + \f (toElem -> c) x -> B.foldr ((toElem .) . f) c x === foldr ((toElem .) . f) c (B.unpack x) + , testProperty "foldr'" $ + \f (toElem -> c) x -> B.foldr' ((toElem .) . f) c x === foldr' ((toElem .) . f) c (B.unpack x) + + , testProperty "foldl cons" $ + \x -> B.foldl (flip B.cons) B.empty x === B.reverse x + , testProperty "foldr cons" $ + \x -> B.foldr B.cons B.empty x === x + , testProperty "foldl special" $ + \(Sqrt x) (toElem -> c) -> B.unpack (B.foldl (\acc t -> if t == c then acc else B.cons t acc) B.empty x) === + foldl (\acc t -> if t == c then acc else t : acc) [] (B.unpack x) + , testProperty "foldr special" $ + \(Sqrt x) (toElem -> c) -> B.unpack (B.foldr (\t acc -> if t == c then acc else B.cons t acc) B.empty x) === + foldr (\t acc -> if t == c then acc else t : acc) [] (B.unpack x) + + , testProperty "foldl1" $ + \f x -> not (B.null x) ==> B.foldl1 ((toElem .) . f) x === foldl1 ((toElem .) . f) (B.unpack x) + , testProperty "foldl1'" $ + \f x -> not (B.null x) ==> B.foldl1' ((toElem .) . f) x === List.foldl1' ((toElem .) . f) (B.unpack x) + , testProperty "foldr1" $ + \f x -> not (B.null x) ==> B.foldr1 ((toElem .) . f) x === foldr1 ((toElem .) . f) (B.unpack x) + , testProperty "foldr1'" $ -- there is not Data.List.foldr1' + \f x -> not (B.null x) ==> B.foldr1' ((toElem .) . f) x === foldr1 ((toElem .) . f) (B.unpack x) + + , testProperty "foldl1 const" $ + \x -> not (B.null x) ==> B.foldl1 const x === B.head x + , testProperty "foldl1 flip const" $ + \x -> not (B.null x) ==> B.foldl1 (flip const) x === B.last x + , testProperty "foldr1 const" $ + \x -> not (B.null x) ==> B.foldr1 const x === B.head x + , testProperty "foldr1 flip const" $ + \x -> not (B.null x) ==> B.foldr1 (flip const) x === B.last x + , testProperty "foldl1 max" $ + \x -> not (B.null x) ==> B.foldl1 max x === B.foldl max minBound x + , testProperty "foldr1 max" $ + \x -> not (B.null x) ==> B.foldr1 max x === B.foldr max minBound x + +#ifndef BYTESTRING_SHORT + , testProperty "scanl" $ + \f (toElem -> c) x -> B.unpack (B.scanl ((toElem .) . f) c x) === scanl ((toElem .) . f) c (B.unpack x) + , testProperty "scanl foldl" $ + \f (toElem -> c) x -> not (B.null x) ==> B.last (B.scanl ((toElem .) . f) c x) === B.foldl ((toElem .) . f) c x + + , testProperty "scanr" $ + \f (toElem -> c) x -> B.unpack (B.scanr ((toElem .) . f) c x) === scanr ((toElem .) . f) c (B.unpack x) + , testProperty "scanl1" $ + \f x -> B.unpack (B.scanl1 ((toElem .) . f) x) === scanl1 ((toElem .) . f) (B.unpack x) + , testProperty "scanl1 empty" $ + \f -> B.scanl1 f B.empty === B.empty + , testProperty "scanr1" $ + \f x -> B.unpack (B.scanr1 ((toElem .) . f) x) === scanr1 ((toElem .) . f) (B.unpack x) + , testProperty "scanr1 empty" $ + \f -> B.scanr1 f B.empty === B.empty +#endif + +#if !defined(BYTESTRING_LAZY) && !defined(BYTESTRING_SHORT) + , testProperty "sort" $ + \x -> B.unpack (B.sort x) === List.sort (B.unpack x) +#endif + +#ifndef BYTESTRING_SHORT + , testProperty "intersperse" $ + \(toElem -> c) x -> B.unpack (B.intersperse c x) === List.intersperse c (B.unpack x) +#endif + , testProperty "intercalate" $ + \(Sqrt x) (Sqrt ys) -> B.unpack (B.intercalate x ys) === List.intercalate (B.unpack x) (map B.unpack ys) + , testProperty "intercalate 'c' [x,y]" $ + \(toElem -> c) x y -> B.unpack (B.intercalate (B.singleton c) [x, y]) === List.intercalate [c] [B.unpack x, B.unpack y] + , testProperty "intercalate split" $ + \(toElem -> c) x -> B.intercalate (B.singleton c) (B.split c x) === x + +#ifndef BYTESTRING_SHORT + , testProperty "mapAccumL" $ + \f (toElem -> c) x -> second B.unpack (B.mapAccumL ((second toElem .) . f) c x) === + List.mapAccumL ((second toElem .) . f) c (B.unpack x) + , testProperty "mapAccumR" $ + \f (toElem -> c) x -> second B.unpack (B.mapAccumR ((second toElem .) . f) c x) === + List.mapAccumR ((second toElem .) . f) c (B.unpack x) + + , testProperty "zip" $ + \x y -> B.zip x y === zip (B.unpack x) (B.unpack y) + , testProperty "zipWith" $ + \f x y -> (B.zipWith f x y :: [Int]) === zipWith f (B.unpack x) (B.unpack y) + , testProperty "packZipWith" $ + \f x y -> B.unpack (B.packZipWith ((toElem .) . f) x y) === zipWith ((toElem .) . f) (B.unpack x) (B.unpack y) +# ifdef BYTESTRING_LAZY + -- Don't use (===) in these laziness tests: + -- We don't want printing the test case to fail! + , testProperty "zip is lazy in the longer input" $ zipLazyInLongerInputTest $ + \x y -> B.zip x y == zip (B.unpack x) (B.unpack y) + , testProperty "zipWith is lazy in the longer input" $ + \f -> zipLazyInLongerInputTest $ + \x y -> (B.zipWith f x y :: [Int]) == zipWith f (B.unpack x) (B.unpack y) + , testProperty "packZipWith is lazy in the longer input" $ + \f -> zipLazyInLongerInputTest $ + \x y -> B.unpack (B.packZipWith ((toElem .) . f) x y) == zipWith ((toElem .) . f) (B.unpack x) (B.unpack y) + , testProperty "zip is maximally lazy" $ \x y -> + zip (B.unpack x) (B.unpack y) `List.isPrefixOf` + B.zip (x <> tooStrictErr) (y <> tooStrictErr) + , testProperty "zipWith is maximally lazy" $ \f x y -> + zipWith f (B.unpack x) (B.unpack y) `List.isPrefixOf` + B.zipWith @Int f (x <> tooStrictErr) (y <> tooStrictErr) + -- (It's not clear if packZipWith is required to be maximally lazy.) +# endif + , testProperty "unzip" $ + \(fmap (toElem *** toElem) -> xs) -> (B.unpack *** B.unpack) (B.unzip xs) === unzip xs +#endif + + , testProperty "index" $ + \(NonNegative n) x -> intToIndexTy n < B.length x ==> B.index x (intToIndexTy n) === B.unpack x !! n + , testProperty "indexMaybe" $ + \(NonNegative n) x -> intToIndexTy n < B.length x ==> B.indexMaybe x (intToIndexTy n) === Just (B.unpack x !! n) + , testProperty "indexMaybe Nothing" $ + \n x -> n < 0 || intToIndexTy n >= B.length x ==> B.indexMaybe x (intToIndexTy n) === Nothing + , testProperty "!?" $ + \(intToIndexTy -> n) x -> B.indexMaybe x n === x B.!? n + +#ifdef BYTESTRING_CHAR8 + , testProperty "isString" $ + \x -> x === fromString (B.unpack x) + , testRdInt @Int "readInt" + , testRdInt @Int8 "readInt8" + , testRdInt @Int16 "readInt16" + , testRdInt @Int32 "readInt32" + , testRdInt @Int64 "readInt64" + , testRdInt @Word "readWord" + , testRdInt @Word8 "readWord8" + , testRdInt @Word16 "readWord16" + , testRdInt @Word32 "readWord32" + , testRdInt @Word64 "readWord64" + , testRdInt @Integer "readInteger" + , testRdInt @Natural "readNatural" + , testProperty "lines" $ + \x -> map B.unpack (B.lines x) === lines (B.unpack x) + , testProperty "lines \\n" $ once $ + let x = B.pack "one\ntwo\n\n\nfive\n\nseven\n" in + map B.unpack (B.lines x) === lines (B.unpack x) + , testProperty "unlines" $ + \xs -> B.unpack (B.unlines xs) === unlines (map B.unpack xs) + , testProperty "words" $ + \x -> map B.unpack (B.words x) === words (B.unpack x) + , testProperty "unwords" $ + \xs -> B.unpack (B.unwords xs) === unwords (map B.unpack xs) +#endif + +#ifndef BYTESTRING_LAZY + , testProperty "unfoldrN" $ + \n f (toElem -> c) -> B.unpack (fst (B.unfoldrN n (fmap (first toElem) . f) c)) === + take (fromIntegral n) (List.unfoldr (fmap (first toElem) . f) c) + , testProperty "unfoldrN replicate" $ + \n (toElem -> c) -> fst (B.unfoldrN n (\t -> Just (t, t)) c) === B.replicate n c + , testProperty "unfoldr" $ + \n a (toElem -> c) -> B.unpack (B.unfoldr (\x -> if x <= 100 * n then Just (c, x + 1 :: Int) else Nothing) a) === + List.unfoldr (\x -> if x <= 100 * n then Just (c, x + 1) else Nothing) a +#endif + +#ifdef BYTESTRING_LAZY + , testProperty "unfoldr" $ + \n f (toElem -> a) -> B.unpack (B.take (fromIntegral n) (B.unfoldr (fmap (first toElem) . f) a)) === + take n (List.unfoldr (fmap (first toElem) . f) a) + , testProperty "repeat" $ + \n (toElem -> c) -> B.take (fromIntegral (n :: Int)) (B.repeat c) === + B.take (fromIntegral n) (B.unfoldr (\a -> Just (a, a)) c) + , testProperty "cycle" $ + \n x -> not (B.null x) ==> B.take (fromIntegral (n :: Int)) (B.cycle x) === + B.take (fromIntegral n) (B.concat (List.unfoldr (\a -> Just (a, a)) x)) + , testProperty "iterate" $ + \n f (toElem -> a) -> B.take (fromIntegral (n :: Int)) (B.iterate (toElem . f) a) === + B.take (fromIntegral n) (B.unfoldr (\x -> Just (toElem (f x), toElem (f x))) a) +#endif + +#ifndef BYTESTRING_CHAR8 + -- issue #393 + , testProperty "fromString non-char8" $ + \s -> fromString s == B.pack (map (fromIntegral . ord :: Char -> Word8) s) + , testProperty "fromString literal" $ + fromString "\0\1\2\3\4" == B.pack [0,1,2,3,4] +#endif + +#ifndef BYTESTRING_SHORT + , testProperty "toConstr is pack" $ + \(x :: BYTESTRING_TYPE) -> showConstr (toConstr x) === "pack" +#ifndef BYTESTRING_CHAR8 + , testProperty "gshow" $ + \x -> gshow x === "(pack " ++ gshow (B.unpack x) ++ ")" +#endif +-- -- gread is broken on bytestring-0.12 and fixed on bytestring-master +-- , testProperty "gread . gshow = reads . show" $ +-- \(x :: BYTESTRING_TYPE) -> gread (gshow x) === (reads (show x) :: [(BYTESTRING_TYPE, String)]) +#endif + ] + +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc xs = Just (init xs, last xs) + +#ifndef BYTESTRING_SHORT +findIndexEnd :: (a -> Bool) -> [a] -> Maybe Int +findIndexEnd f xs = fmap (\n -> length xs - 1 - n) (List.findIndex f (reverse xs)) + +elemIndexEnd :: Eq a => a -> [a] -> Maybe Int +elemIndexEnd c xs = fmap (\n -> length xs - 1 - n) (List.elemIndex c (reverse xs)) +#endif + +stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] +stripSuffix x y = fmap reverse (List.stripPrefix (reverse x) (reverse y)) + +split :: Eq a => a -> [a] -> [[a]] +split c = splitWith (== c) + +splitWith :: (a -> Bool) -> [a] -> [[a]] +splitWith _ [] = [] +splitWith f ys = go [] ys + where + go acc [] = [reverse acc] + go acc (x : xs) + | f x = reverse acc : go [] xs + | otherwise = go (x : acc) xs + +#ifdef BYTESTRING_CHAR8 +readInt :: String -> Maybe (Int, String) +readInt xs = case readInteger xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readWord :: String -> Maybe (Word, String) +readWord xs = case readIntegerUnsigned xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readInt8 :: String -> Maybe (Int8, String) +readInt8 xs = case readInteger xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readWord8 :: String -> Maybe (Word8, String) +readWord8 xs = case readIntegerUnsigned xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readInt16 :: String -> Maybe (Int16, String) +readInt16 xs = case readInteger xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readWord16 :: String -> Maybe (Word16, String) +readWord16 xs = case readIntegerUnsigned xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readInt32 :: String -> Maybe (Int32, String) +readInt32 xs = case readInteger xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readWord32 :: String -> Maybe (Word32, String) +readWord32 xs = case readIntegerUnsigned xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readInt64 :: String -> Maybe (Int64, String) +readInt64 xs = case readInteger xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readWord64 :: String -> Maybe (Word64, String) +readWord64 xs = case readIntegerUnsigned xs of + Just (y, zs) + | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) + otherwise -> Nothing + +readInteger :: String -> Maybe (Integer, String) +readInteger ('+' : xs) = readIntegerUnsigned xs +readInteger ('-' : xs) = fmap (first negate) (readIntegerUnsigned xs) +readInteger xs = readIntegerUnsigned xs + +readNatural :: String -> Maybe (Natural, String) +readNatural xs = case readIntegerUnsigned xs of + Just (y, zs) + | y >= 0 -> Just (fromIntegral @Integer @Natural y, zs) + _ -> Nothing + +readIntegerUnsigned :: String -> Maybe (Integer, String) +readIntegerUnsigned xs = case readMaybe ys of + Just y -> Just (y, zs) + otherwise -> Nothing + where + (ys, zs) = span isDigit xs +#endif + +#ifdef BYTESTRING_LAZY +zipLazyInLongerInputTest + :: Testable prop + => (BYTESTRING_TYPE -> BYTESTRING_TYPE -> prop) + -> BYTESTRING_TYPE -> BYTESTRING_TYPE -> Property +zipLazyInLongerInputTest fun = \x0 y0 -> let + msg = "Input chunks are: " ++ show (B.toChunks x0, B.toChunks y0) + (x, y) | B.length x0 <= B.length y0 + = (x0, y0 <> tooStrictErr) + | otherwise + = (x0 <> tooStrictErr, y0) + in counterexample msg (fun x y) +#endif diff --git a/tests/Properties/ByteStringChar8.hs b/tests/Properties/ByteStringChar8.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ByteStringChar8.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} + +#define BYTESTRING_CHAR8 + +#include "ByteString.hs" diff --git a/tests/Properties/ByteStringLazy.hs b/tests/Properties/ByteStringLazy.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ByteStringLazy.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} + +#define BYTESTRING_LAZY + +#include "ByteString.hs" diff --git a/tests/Properties/ByteStringLazyChar8.hs b/tests/Properties/ByteStringLazyChar8.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ByteStringLazyChar8.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE CPP #-} + +#define BYTESTRING_LAZY +#define BYTESTRING_CHAR8 + +#include "ByteString.hs" diff --git a/tests/Properties/ShortByteString.hs b/tests/Properties/ShortByteString.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ShortByteString.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} + +#define BYTESTRING_SHORT + +#include "ByteString.hs" diff --git a/tests/QuickCheckUtils.hs b/tests/QuickCheckUtils.hs --- a/tests/QuickCheckUtils.hs +++ b/tests/QuickCheckUtils.hs @@ -1,25 +1,30 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, - FlexibleInstances, FlexibleContexts, - TypeSynonymInstances #-} --- --- Uses multi-param type classes --- -module QuickCheckUtils where +{-# 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.List 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.Lazy.Internal as L (checkInvariant,ByteString(..)) import qualified Data.ByteString.Char8 as PC import qualified Data.ByteString.Lazy.Char8 as LC @@ -34,6 +39,7 @@ 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) @@ -42,13 +48,14 @@ arbitrary = sized $ \n -> do numChunks <- choose (0, n) if numChunks == 0 then return L.empty - else fmap (L.checkInvariant . - L.fromChunks . + 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) @@ -72,6 +79,7 @@ where toChar :: Word8 -> Char toChar = toEnum . fromIntegral + shrink (Char8 c) = fmap Char8 (shrink c) instance CoArbitrary Char8 where coarbitrary (Char8 c) = coarbitrary c @@ -86,112 +94,49 @@ where toChar :: Word8 -> Char toChar = toEnum . fromIntegral + shrink (String8 xs) = fmap String8 (shrink xs) ------------------------------------------------------------------------- --- --- We're doing two forms of testing here. Firstly, model based testing. --- For our Lazy and strict bytestring types, we have model types: --- --- i.e. Lazy == Byte --- \\ // --- List --- --- That is, the Lazy type can be modeled by functions in both the Byte --- and List type. For each of the 3 models, we have a set of tests that --- check those types match. --- --- The Model class connects a type and its model type, via a conversion --- function. --- --- -class Model a b where - model :: a -> b -- ^ Get the abstract value from a concrete value +-- | 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) --- | Alias for 'model' that's a better name in the situations where we're --- really just converting functions that take or return Char8. -castFn :: Model a b => a -> b -castFn = model +instance Arbitrary a => Arbitrary (Sqrt a) where + arbitrary = Sqrt <$> sized + (\n -> resize (round @Double $ sqrt $ fromIntegral @Int n) arbitrary) + shrink = map Sqrt . shrink . unSqrt --- --- Connecting our Lazy and Strict types to their models. We also check --- the data invariant on Lazy types. --- --- These instances represent the arrows in the above diagram --- -instance Model B P where model = abstr . checkInvariant -instance Model P [W] where model = P.unpack -instance Model P [Char] where model = PC.unpack -instance Model B [W] where model = L.unpack . checkInvariant -instance Model B [Char] where model = LC.unpack . checkInvariant -instance Model Char8 Char where model (Char8 c) = c --- Types are trivially modeled by themselves -instance Model Bool Bool where model = id -instance Model Int Int where model = id -instance Model P P where model = id -instance Model B B where model = id -instance Model Int64 Int64 where model = id -instance Model Word8 Word8 where model = id -instance Model Ordering Ordering where model = id -instance Model Char Char where model = id - --- More structured types are modeled recursively, using the NatTrans class from Gofer. -class (Functor f, Functor g) => NatTrans f g where - eta :: f a -> g a - --- The transformation of the same type is identity -instance NatTrans [] [] where eta = id -instance NatTrans Maybe Maybe where eta = id -instance NatTrans ((->) X) ((->) X) where eta = id -instance NatTrans ((->) Char) ((->) Char) where eta = id -instance NatTrans ((->) Char8) ((->) Char) where eta f = f . Char8 - -instance NatTrans ((->) W) ((->) W) where eta = id - --- We have a transformation of pairs, if the pairs are in Model -instance Model f g => NatTrans ((,) f) ((,) g) where eta (f,a) = (model f, a) - --- And finally, we can take any (m a) to (n b), if we can Model m n, and a b -instance (NatTrans m n, Model a b) => Model (m a) (n b) where model x = fmap model (eta x) - ------------------------------------------------------------------------- - --- In a form more useful for QC testing (and it's lazy) -checkInvariant :: L.ByteString -> L.ByteString -checkInvariant = L.checkInvariant - -abstr :: L.ByteString -> P.ByteString -abstr = P.concat . L.toChunks +sizedShortByteString :: Int -> Gen SB.ShortByteString +sizedShortByteString n = do m <- choose(0, n) + fmap SB.pack $ vectorOf m arbitrary --- Some short hand. -type X = Int -type W = Word8 -type P = P.ByteString -type B = L.ByteString +instance Arbitrary SB.ShortByteString where + arbitrary = sized sizedShortByteString + shrink = map SB.pack . shrink . SB.unpack ------------------------------------------------------------------------- --- --- These comparison functions handle wrapping and equality. --- --- A single class for these would be nice, but note that they differe in --- the number of arguments, and those argument types, so we'd need HList --- tricks. See here: http://okmij.org/ftp/Haskell/vararg-fn.lhs --- +instance CoArbitrary SB.ShortByteString where + coarbitrary s = coarbitrary (SB.unpack s) -eq1 f g = \a -> - model (f a) == g (model a) -eq2 f g = \a b -> - model (f a b) == g (model a) (model b) -eq3 f g = \a b c -> - model (f a b c) == g (model a) (model b) (model c) +-- | This /poison instance/ exists to make accidental mis-use +-- of the @Arbitrary Int64@ instance a bit less likely. +instance {-# OVERLAPPING #-} + TypeError (Text "Found a test taking a raw Int64 argument." + :$$: Text "'instance Arbitrary Int64' by default is likely to" + :$$: Text "produce very large numbers after the first few tests," + :$$: Text "which doesn't make great indices into a LazyByteString." + :$$: Text "For indices, try 'intToIndexTy' in Properties/ByteString.hs." + :$$: Text "" + :$$: Text "If very few small-numbers tests is OK, use" + :$$: Text "'int64OK' to bypass this poison-instance." + ) => Testable (Int64 -> prop) where + property = error "poison instance Testable (Int64 -> prop)" --- --- And for functions that take non-null input --- -eqnotnull1 f g = \x -> (not (isNull x)) ==> eq1 f g x -eqnotnull2 f g = \x y -> (not (isNull y)) ==> eq2 f g x y -eqnotnull3 f g = \x y z -> (not (isNull z)) ==> eq3 f g x y z +-- | Use this to bypass the poison instance for @Testable (Int64 -> prop)@ +-- defined in "QuickCheckUtils". +int64OK :: (Arbitrary a, Show a, Testable b) => (a -> b) -> Property +int64OK f = propertyForAllShrinkShow arbitrary shrink (\v -> [show v]) f -class IsNull t where isNull :: t -> Bool -instance IsNull L.ByteString where isNull = L.null -instance IsNull P.ByteString where isNull = P.null +tooStrictErr :: forall a. HasCallStack => a +tooStrictErr = withFrozenCallStack $ + error "A lazy sub-expression was unexpectedly evaluated" diff --git a/tests/Rules.hs b/tests/Rules.hs deleted file mode 100644 --- a/tests/Rules.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Rules where --- --- Tests to ensure rules are firing. --- - -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString as P -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Char8 as D -import Data.List -import Data.Char -import Data.Word - -import QuickCheckUtils - -import Test.Tasty.QuickCheck - -prop_break_C :: Word8 -> C.ByteString -> Bool -prop_break_C w = C.break ((==) x) `eq1` break ((==) x) - where - -- Make sure we're not testing non-octet character values, for which - -- C.break is not isomorphic to breaking the corresponding string, - -- Instead start with a byte, and make a character out of that. - x = chr $ fromIntegral w - -prop_break_P :: Word8 -> C.ByteString -> Bool -prop_break_P x = P.break ((==) x) `eq1` break ((==) x) -prop_intercalate_P c = (\s1 s2 -> P.intercalate (P.singleton c) (s1 : s2 : [])) - `eq2` - (\s1 s2 -> intercalate [c] (s1 : s2 : [])) - -prop_break_isSpace_C = C.break isSpace `eq1` break isSpace -prop_dropWhile_isSpace_C = C.dropWhile isSpace `eq1` dropWhile isSpace - -rules = - [ testProperty "break (==)" prop_break_C - , testProperty "break (==)" prop_break_P - , testProperty "break isSpace" prop_break_isSpace_C - , testProperty "dropWhile isSpace" prop_dropWhile_isSpace_C - , testProperty "intercalate" prop_intercalate_P - ] diff --git a/tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs b/tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs --- a/tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs +++ b/tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + -- | -- Copyright : (c) 2011 Simon Meier -- License : BSD3-style (see LICENSE) @@ -59,6 +60,8 @@ , double_list , coerceFloatToWord32 , coerceDoubleToWord64 + , coerceWord32ToFloat + , coerceWord64ToDouble ) where @@ -76,13 +79,13 @@ import Data.Word import Foreign (Storable(..), castPtr, minusPtr, with) import Numeric (showHex) -import GHC.ByteOrder import System.IO.Unsafe (unsafePerformIO) import Test.Tasty -import Test.Tasty.HUnit (assertBool, testCase) import Test.Tasty.QuickCheck (Arbitrary(..), testProperty) +#include + -- Helper functions ------------------- @@ -92,8 +95,8 @@ => String -> (a -> Bool) -> TestTree testBoundedProperty name p = testGroup name [ testProperty name p - , testCase (name ++ " minBound") $ assertBool "minBound" (p (minBound :: a)) - , testCase (name ++ " maxBound") $ assertBool "minBound" (p (maxBound :: a)) + , testProperty (name ++ " minBound") (p (minBound :: a)) + , testProperty (name ++ " maxBound") (p (maxBound :: a)) ] -- | Quote a 'String' nicely. @@ -330,10 +333,14 @@ 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] -hostEndian_list = case targetByteOrder of - LittleEndian -> littleEndian_list - BigEndian -> bigEndian_list +#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 @@ -350,6 +357,16 @@ {-# 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]) diff --git a/tests/builder/Data/ByteString/Builder/Prim/Tests.hs b/tests/builder/Data/ByteString/Builder/Prim/Tests.hs --- a/tests/builder/Data/ByteString/Builder/Prim/Tests.hs +++ b/tests/builder/Data/ByteString/Builder/Prim/Tests.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE MagicHash #-} - -- | -- Copyright : (c) 2011 Simon Meier -- License : BSD3-style (see LICENSE) diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs b/tests/builder/Data/ByteString/Builder/Tests.hs --- a/tests/builder/Data/ByteString/Builder/Tests.hs +++ b/tests/builder/Data/ByteString/Builder/Tests.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -- | -- Copyright : (c) 2011 Simon Meier -- License : BSD3-style (see LICENSE) @@ -14,17 +10,20 @@ 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) +import Foreign (minusPtr, castPtr, ForeignPtr, withForeignPtr, Int64) import Data.Char (chr) -import qualified Data.DList as D +import Data.Bits ((.|.), shiftL) import Data.Foldable +import Data.Semigroup (Semigroup(..)) import Data.Word import qualified Data.ByteString as S @@ -41,14 +40,19 @@ import Control.Exception (evaluate) import System.IO (openTempFile, hPutStr, hClose, hSetBinaryMode, hSetEncoding, utf8, hSetNewlineMode, noNewlineTranslation) -import Foreign (ForeignPtr, withForeignPtr, castPtr) 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, UnicodeString(..), Property, testProperty ) + , counterexample, ioProperty, Property, testProperty + , (===), (.&&.), conjoin, forAll, forAllShrink + , UnicodeString(..), NonNegative(..), Positive(..) + , mapSize, (==>) + ) +import QuickCheckUtils tests :: [TestTree] @@ -58,12 +62,16 @@ , testHandlePutBuilderChar8 , testPut , testRunBuilder + , testWriteFile + , testStimes ] ++ testsEncodingToBuilder ++ testsBinary ++ testsASCII ++ + testsFloating ++ testsChar8 ++ - testsUtf8 + testsUtf8 ++ + [testLaziness] ------------------------------------------------------------------------------ @@ -94,20 +102,10 @@ testRecipe :: (UnicodeString, UnicodeString, UnicodeString, Recipe) -> Property testRecipe args = ioProperty $ do - let (UnicodeString a1, UnicodeString a2, UnicodeString a3, recipe) = args -#if MIN_VERSION_base(4,5,0) - before = a1 - between = a2 - after = a3 -#else - -- See https://github.com/haskell/bytestring/issues/212 - -- write -> read does not roundrip with GHC 7.2 and - -- characters in the \xEF00-\xEFFF range. - safeChr = \c -> c < '\xEF00' || c > '\xEFFF' - before = filter safeChr a1 - between = filter safeChr a2 - after = filter safeChr a3 -#endif + let { ( UnicodeString before + , UnicodeString between + , UnicodeString after + , recipe) = args } (tempFile, tempH) <- openTempFile "." "test-builder.tmp" -- switch to UTF-8 encoding hSetEncoding tempH utf8 @@ -173,6 +171,37 @@ 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 @@ -207,31 +236,45 @@ 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) = - D.toList $ evalState (execWriterT (traverse_ renderAction as)) firstSize - `D.append` renderLBS cont + fromDList $ evalState (execWriterT (traverse_ renderAction as)) firstSize <> renderLBS cont where - renderAction :: Monad m => Action -> WriterT (D.DList Word8) (StateT Int m) () + renderAction :: Monad m => Action -> WriterT (DList Word8) (StateT Int m) () renderAction (SBS Hex bs) = tell $ foldMap hexWord8 $ S.unpack bs - renderAction (SBS _ bs) = tell $ D.fromList $ 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 $ D.fromList $ Sh.unpack sbs - renderAction (W8 w) = tell $ return w - renderAction (W8S ws) = tell $ D.fromList ws - renderAction (String cs) = tell $ foldMap (D.fromList . charUtf8_list) cs - renderAction Flush = tell $ D.empty - renderAction (EnsureFree _) = tell $ D.empty - renderAction (FDec f) = tell $ D.fromList $ encodeASCII $ show f - renderAction (DDec d) = tell $ D.fromList $ encodeASCII $ show d + 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 (D.fromList $ encodeASCII $ show s) + tell (toDList $ encodeASCII $ show s) lift $ put (s - i) - renderLBS = D.fromList . L.unpack - hexWord8 = D.fromList . wordHexFixed_list + renderLBS = toDList . L.unpack + hexWord8 = toDList . wordHexFixed_list buildAction :: Action -> StateT Int Put () buildAction (SBS Hex bs) = lift $ putBuilder $ byteStringHex bs @@ -279,22 +322,6 @@ -- 'Arbitary' instances ----------------------- -instance Arbitrary L.ByteString where - arbitrary = L.fromChunks <$> listOf arbitrary - shrink lbs - | L.null lbs = [] - | otherwise = pure $ L.take (L.length lbs `div` 2) lbs - -instance Arbitrary S.ByteString where - arbitrary = - trim S.drop =<< trim S.take =<< S.pack <$> listOf arbitrary - where - trim f bs = oneof [pure bs, f <$> choose (0, S.length bs) <*> pure bs] - - shrink bs - | S.null bs = [] - | otherwise = pure $ S.take (S.length bs `div` 2) bs - instance Arbitrary Mode where arbitrary = oneof [Threshold <$> arbitrary, pure Smart, pure Insert, pure Copy, pure Hex] @@ -507,13 +534,20 @@ testBuilderConstr name ref mkBuilder = testProperty name check where - check x = - (ws ++ ws) == - (L.unpack $ toLazyByteString $ mkBuilder x `BI.append` mkBuilder x) - where - ws = ref x + 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 @@ -601,6 +635,342 @@ 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 @@ -611,4 +981,45 @@ testsUtf8 = [ testBuilderConstr "charUtf8" charUtf8_list charUtf8 , testBuilderConstr "stringUtf8" (foldMap charUtf8_list) stringUtf8 + ] + +testLaziness :: TestTree +testLaziness = testGroup "Builder laziness" + [ testProperty "byteString" $ mapSize (+ 10) $ + \bs (Positive chunkSize) -> + let strategy = safeStrategy chunkSize chunkSize + lbs = toLazyByteStringWith strategy L.empty + (byteString bs <> tooStrictErr) + in (S.length bs > max chunkSize 8) ==> L.head lbs == S.head bs + , testProperty "byteStringCopy" $ mapSize (+ 10) $ + \bs (Positive chunkSize) -> + let strategy = safeStrategy chunkSize chunkSize + lbs = toLazyByteStringWith strategy L.empty + (byteStringCopy bs <> tooStrictErr) + in (S.length bs > max chunkSize 8) ==> L.head lbs == S.head bs + , testProperty "byteStringInsert" $ mapSize (+ 10) $ + \bs (Positive chunkSize) -> + let strategy = safeStrategy chunkSize chunkSize + lbs = toLazyByteStringWith strategy L.empty + (byteStringInsert bs <> tooStrictErr) + in L.take (fromIntegral @Int @Int64 (S.length bs)) lbs + == L.fromStrict bs + , testProperty "lazyByteString" $ mapSize (+ 10) $ + \bs (Positive chunkSize) -> + let strategy = safeStrategy chunkSize chunkSize + lbs = toLazyByteStringWith strategy L.empty + (lazyByteString bs <> tooStrictErr) + in (L.length bs > fromIntegral @Int @Int64 (max chunkSize 8)) + ==> L.head lbs == L.head bs + , testProperty "shortByteString" $ mapSize (+ 10) $ + \bs (Positive chunkSize) -> + let strategy = safeStrategy chunkSize chunkSize + lbs = toLazyByteStringWith strategy L.empty + (shortByteString bs <> tooStrictErr) + in (Sh.length bs > max chunkSize 8) ==> L.head lbs == Sh.head bs + , testProperty "flush" $ \recipe -> let + !(b, toLBS) = recipeComponents recipe + !lbs1 = toLazyByteString b + !lbs2 = L.take (L.length lbs1) (toLBS $ b <> flush <> tooStrictErr) + in lbs1 == lbs2 ] diff --git a/tests/builder/TestSuite.hs b/tests/builder/TestSuite.hs deleted file mode 100644 --- a/tests/builder/TestSuite.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Main where - -import qualified Data.ByteString.Builder.Tests -import qualified Data.ByteString.Builder.Prim.Tests -import Test.Tasty (defaultMain, TestTree, testGroup) - -main :: IO () -main = defaultMain $ testGroup "All" tests - -tests :: [TestTree] -tests = - [ testGroup "Data.ByteString.Builder" - Data.ByteString.Builder.Tests.tests - - , testGroup "Data.ByteString.Builder.BasicEncoding" - Data.ByteString.Builder.Prim.Tests.tests - ]