diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,26 @@ +[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 +78,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,11 +1,8 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_HADDOCK prune #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif -- | -- Module : Data.ByteString @@ -43,173 +40,179 @@ module Data.ByteString ( - -- * The @ByteString@ type - ByteString, -- abstract, instances: Eq, Ord, Show, Read, Data, Typeable, Monoid + -- * Strict @ByteString@ + ByteString, + StrictByteString, -- * Introducing and eliminating 'ByteString's - empty, -- :: ByteString - singleton, -- :: Word8 -> ByteString - pack, -- :: [Word8] -> ByteString - unpack, -- :: ByteString -> [Word8] - fromStrict, -- :: ByteString -> Lazy.ByteString - toStrict, -- :: Lazy.ByteString -> ByteString + empty, + singleton, + pack, + unpack, + fromStrict, + toStrict, + fromFilePath, + toFilePath, -- * 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 + 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 + foldl, + foldl', + foldl1, + foldl1', - 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 + 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 + concat, + concatMap, + any, + all, + maximum, + minimum, -- * 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, -- ** 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) + 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, -- :: (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 + take, + takeEnd, + drop, + dropEnd, + splitAt, + takeWhile, + takeWhileEnd, + dropWhile, + dropWhileEnd, + span, + spanEnd, + break, + breakEnd, + group, + groupBy, + inits, + tails, + 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, + -- ** Encoding validation + isValidUtf8, + -- ** Search for arbitrary substrings - breakSubstring, -- :: ByteString -> ByteString -> (ByteString,ByteString) + breakSubstring, -- * 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 -> 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 + index, + indexMaybe, + (!?), + elemIndex, + elemIndices, + elemIndexEnd, + findIndex, + findIndices, + findIndexEnd, + 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 + copy, -- ** Packing 'CString's and pointers - packCString, -- :: CString -> IO ByteString - packCStringLen, -- :: CStringLen -> IO ByteString + packCString, + packCStringLen, -- ** Using ByteStrings as 'CString's - useAsCString, -- :: ByteString -> (CString -> IO a) -> IO a - useAsCStringLen, -- :: ByteString -> (CStringLen -> IO a) -> IO a + useAsCString, + useAsCStringLen, -- * I\/O with 'ByteString's -- ** Standard input and output - getLine, -- :: IO ByteString - getContents, -- :: IO ByteString - putStr, -- :: ByteString -> IO () - interact, -- :: (ByteString -> ByteString) -> IO () + getLine, + getContents, + putStr, + interact, -- ** Files - readFile, -- :: FilePath -> IO ByteString - writeFile, -- :: FilePath -> ByteString -> IO () - appendFile, -- :: FilePath -> ByteString -> IO () + readFile, + writeFile, + appendFile, -- ** 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 () + hGetLine, + hGetContents, + hGet, + hGetSome, + hGetNonBlocking, + hPut, + hPutNonBlocking, + hPutStr, ) where import qualified Prelude as P @@ -222,16 +225,9 @@ ,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) @@ -245,13 +241,9 @@ import Control.Monad (when, void) import Foreign.C.String (CString, CStringLen) -import Foreign.C.Types (CSize) +import Foreign.C.Types (CSize (CSize), CInt (CInt)) 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 @@ -264,27 +256,21 @@ ,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.Encoding (getFileSystemEncoding) import GHC.IO (unsafePerformIO, unsafeDupablePerformIO) +import GHC.Foreign (newCStringLen, peekCStringLen) +import GHC.Stack.Types (HasCallStack) 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 @@ -342,6 +328,41 @@ 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 @@ -376,11 +397,9 @@ 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 :: HasCallStack => ByteString -> Word8 head (BS x l) | l <= 0 = errorEmptyList "head" | otherwise = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> peek p @@ -388,7 +407,7 @@ -- | /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 :: HasCallStack => ByteString -> ByteString tail (BS p l) | l <= 0 = errorEmptyList "tail" | otherwise = BS (plusForeignPtr p 1) (l-1) @@ -406,7 +425,7 @@ -- | /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 :: HasCallStack => ByteString -> Word8 last ps@(BS x l) | null ps = errorEmptyList "last" | otherwise = accursedUnutterablePerformIO $ @@ -415,7 +434,7 @@ -- | /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 :: HasCallStack => ByteString -> ByteString init ps@(BS p l) | null ps = errorEmptyList "init" | otherwise = BS p (l-1) @@ -484,8 +503,8 @@ -- 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 +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 @@ -494,14 +513,26 @@ 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) = - accursedUnutterablePerformIO $ unsafeWithForeignPtr fp g - where +foldl' f v = \(BS fp len) -> + -- see fold inlining + let g ptr = go v ptr where end = ptr `plusPtr` len @@ -509,14 +540,17 @@ go !z !p | p == end = return z | otherwise = do x <- peek p go (f z x) (p `plusPtr` 1) + in + accursedUnutterablePerformIO $ unsafeWithForeignPtr fp g {-# 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 +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 @@ -526,13 +560,15 @@ 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) = - accursedUnutterablePerformIO $ unsafeWithForeignPtr fp g - where +foldr' k v = \(BS fp len) -> + -- see fold inlining + let g ptr = go v (end `plusPtr` len) where end = ptr `plusPtr` (-1) @@ -540,12 +576,15 @@ go !z !p | p == end = return z | otherwise = do x <- peek p go (k x z) (p `plusPtr` (-1)) + in + accursedUnutterablePerformIO $ unsafeWithForeignPtr fp g + {-# 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 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8 foldl1 f ps = case uncons ps of Nothing -> errorEmptyList "foldl1" Just (h, t) -> foldl f h t @@ -553,7 +592,7 @@ -- | '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' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8 foldl1' f ps = case uncons ps of Nothing -> errorEmptyList "foldl1'" Just (h, t) -> foldl' f h t @@ -562,7 +601,7 @@ -- | '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 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8 foldr1 f ps = case unsnoc ps of Nothing -> errorEmptyList "foldr1" Just (b, c) -> foldr f c b @@ -570,7 +609,7 @@ -- | 'foldr1'' is a variant of 'foldr1', but is strict in the -- accumulator. -foldr1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldr1' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8 foldr1' f ps = case unsnoc ps of Nothing -> errorEmptyList "foldr1'" Just (b, c) -> foldr' f c b @@ -604,21 +643,12 @@ 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 @@ -627,8 +657,6 @@ 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 @@ -645,28 +673,18 @@ 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 :: HasCallStack => ByteString -> Word8 maximum xs@(BS x l) | null xs = errorEmptyList "maximum" | otherwise = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> @@ -674,9 +692,8 @@ {-# 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 :: HasCallStack => ByteString -> Word8 minimum xs@(BS x l) | null xs = errorEmptyList "minimum" | otherwise = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> @@ -690,20 +707,21 @@ -- 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 +mapAccumL f acc = \(BS fp len) -> unsafeDupablePerformIO $ unsafeWithForeignPtr fp $ \a -> 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 <- peekByteOff src n + let (s', y) = f s x + pokeByteOff dst n y + mapAccumL_ s' (n+1) 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 @@ -711,26 +729,27 @@ -- 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 +mapAccumR f acc = \(BS fp len) -> unsafeDupablePerformIO $ unsafeWithForeignPtr fp $ \a -> 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 <- peekByteOff src n + let (s', y) = f s x + pokeByteOff dst n y + mapAccumR_ s' (n-1) 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. +-- reduced values from the left. -- -- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] -- @@ -748,28 +767,24 @@ -- ^ input of length n -> ByteString -- ^ output of length n+1 -scanl f v (BS fp len) = unsafeDupablePerformIO $ unsafeWithForeignPtr fp $ \a -> +scanl f v = \(BS fp len) -> unsafeDupablePerformIO $ unsafeWithForeignPtr fp $ \a -> + -- see fold inlining create (len+1) $ \q -> do poke q v + let + 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) 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 @@ -797,20 +812,21 @@ -- ^ 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) +scanr f v = \(BS fp len) -> unsafeDupablePerformIO $ unsafeWithForeignPtr fp $ \a -> + -- see fold inlining + create (len+1) $ \b -> do + poke (b `plusPtr` len) v + let + 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) + go a b {-# INLINE scanr #-} -- | 'scanr1' is a variant of 'scanr' that has no starting value argument. @@ -870,12 +886,14 @@ | 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) + 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 pokeByteOff p n' w + go' x'' (n'+1) {-# INLINE unfoldrN #-} -- --------------------------------------------------------------------- @@ -950,7 +968,6 @@ 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 @@ -961,18 +978,6 @@ "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. @@ -991,7 +996,6 @@ 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 @@ -1002,18 +1006,6 @@ "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 @@ -1043,21 +1035,12 @@ {-# 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: @@ -1111,21 +1094,12 @@ {-# 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. @@ -1204,8 +1178,7 @@ 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) + else let i = q `minusPtr` unsafeForeignPtrToPtr x in BS (plusForeignPtr x n) (i-n) : loop (i+1) {-# INLINE split #-} @@ -1266,7 +1239,7 @@ -- Indexing ByteStrings -- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0. -index :: ByteString -> Int -> Word8 +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 @@ -1346,7 +1319,7 @@ -- 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 +findIndex k (BS x l) = accursedUnutterablePerformIO $ unsafeWithForeignPtr x g where g !ptr = go 0 where @@ -1363,7 +1336,7 @@ -- -- @since 0.10.12.0 findIndexEnd :: (Word8 -> Bool) -> ByteString -> Maybe Int -findIndexEnd k (BS x l) = accursedUnutterablePerformIO $ withForeignPtr x g +findIndexEnd k (BS x l) = accursedUnutterablePerformIO $ unsafeWithForeignPtr x g where g !ptr = go (l-1) where @@ -1387,21 +1360,12 @@ {-# 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 @@ -1420,21 +1384,24 @@ -- 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 +filter k = \ps@(BS x l) -> + -- see fold inlining. + if null ps + then ps + else + unsafePerformIO $ createAndTrim l $ \pOut -> unsafeWithForeignPtr x $ \pIn -> do + let + 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 + t <- go' pIn pOut + return $! t `minusPtr` pOut -- actual length {-# INLINE filter #-} {- @@ -1481,7 +1448,7 @@ partition :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) partition f s = unsafeDupablePerformIO $ do fp' <- mallocByteString len - withForeignPtr fp' $ \p -> + unsafeWithForeignPtr fp' $ \p -> do let end = p `plusPtr` (len - 1) mid <- sep 0 p end rev mid end @@ -1520,7 +1487,7 @@ | l1 == 0 = True | l2 < l1 = False | otherwise = accursedUnutterablePerformIO $ unsafeWithForeignPtr x1 $ \p1 -> - withForeignPtr x2 $ \p2 -> do + unsafeWithForeignPtr x2 $ \p2 -> do i <- memcmp p1 p2 (fromIntegral l1) return $! i == 0 @@ -1548,7 +1515,7 @@ | l1 == 0 = True | l2 < l1 = False | otherwise = accursedUnutterablePerformIO $ unsafeWithForeignPtr x1 $ \p1 -> - withForeignPtr x2 $ \p2 -> do + unsafeWithForeignPtr x2 $ \p2 -> do i <- memcmp p1 (p2 `plusPtr` (l2 - l1)) (fromIntegral l1) return $! i == 0 @@ -1564,6 +1531,17 @@ 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 + i <- cIsValidUtf8 p (fromIntegral len) + pure $ i /= 0 + +foreign import ccall unsafe "bytestring_is_valid_utf8" cIsValidUtf8 + :: Ptr Word8 -> CSize -> IO CInt + -- | 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. -- @@ -1672,8 +1650,8 @@ -- @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 -> + unsafeWithForeignPtr fp $ \a -> + unsafeWithForeignPtr fq $ \b -> create len $ go a b where go p1 p2 = zipWith_ 0 @@ -1722,7 +1700,7 @@ sort :: ByteString -> ByteString sort (BS input l) -- qsort outperforms counting sort for small arrays - | l <= 20 = unsafeCreate l $ \ptr -> withForeignPtr input $ \inp -> do + | l <= 20 = unsafeCreate l $ \ptr -> unsafeWithForeignPtr input $ \inp -> do memcpy ptr inp (fromIntegral l) c_sort ptr (fromIntegral l) | otherwise = unsafeCreate l $ \p -> allocaArray 256 $ \arr -> do @@ -1757,11 +1735,12 @@ -- 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) + allocaBytes (l+1) $ \buf -> + -- Cannot use unsafeWithForeignPtr, because action can diverge + 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@. @@ -2036,15 +2015,15 @@ -- 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 (moduleErrorMsg fun msg) {-# NOINLINE moduleError #-} -moduleErrorIO :: String -> String -> IO a +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,7 @@ -{-# LANGUAGE CPP, MagicHash #-} -{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-orphans #-} -#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE Trustworthy #-} -#endif +{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-orphans #-} {- | Copyright : (c) 2010 Jasper Van der Jeugt (c) 2010 - 2011 Simon Meier License : BSD3-style (see LICENSE) @@ -191,6 +190,7 @@ -- about fine-tuning them. , toLazyByteString , hPutBuilder + , writeFile -- * Creating Builders @@ -252,16 +252,20 @@ , 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) @@ -294,6 +298,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,8 @@ -{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface, - MagicHash, UnboxedTuples #-} -{-# OPTIONS_HADDOCK not-home #-} -#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE Trustworthy #-} -#endif + +{-# OPTIONS_HADDOCK not-home #-} + -- | Copyright : (c) 2010 - 2011 Simon Meier -- License : BSD3-style (see LICENSE) -- @@ -81,52 +80,16 @@ import Data.ByteString.Lazy as L import Data.ByteString.Builder.Internal (Builder) import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Builder.Prim.Internal as P +import Data.ByteString.Builder.RealFloat (floatDec, doubleDec) import 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 ------------------------------------------------------------------------------ - --- | Encode a 'String' using 'P.char7'. -{-# INLINE string7 #-} -string7 :: String -> Builder -string7 = P.primMapListFixed P.char7 - ------------------------------------------------------------------------------- --- Decimal Encoding ------------------------------------------------------------------------------- - -- Signed integers ------------------ @@ -191,22 +154,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 ------------------------------------------------------------------------------ @@ -308,14 +255,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,8 +271,8 @@ -- | 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 @@ -349,18 +293,18 @@ 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 + 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) + putH (n:ns) = case n `quotRem` maxPow10 of + (x,y) | q > 0 -> q : r : putB ns | otherwise -> r : putB ns where q = fromInteger x @@ -368,8 +312,8 @@ 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" @@ -383,12 +327,3 @@ 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 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,11 +1,5 @@ {-# 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 {-# OPTIONS_HADDOCK not-home #-} -- | Copyright : (c) 2010 - 2011 Simon Meier -- License : BSD3-style (see LICENSE) @@ -134,13 +128,9 @@ import Control.Arrow (second) -#if !(MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0) +#if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup((<>))) #endif -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -import Control.Applicative (Applicative(..),(<$>)) -#endif import qualified Data.ByteString as S import qualified Data.ByteString.Internal as S @@ -153,18 +143,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 @@ -401,21 +382,15 @@ append :: Builder -> Builder -> Builder append (Builder b1) (Builder b2) = Builder $ b1 . b2 -#if MIN_VERSION_base(4,9,0) instance Semigroup Builder where {-# INLINE (<>) #-} (<>) = append -#endif 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 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,7 @@ -{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} +{-# LANGUAGE 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) @@ -472,17 +466,9 @@ 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 @@ -681,13 +667,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 @@ -705,8 +688,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 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,5 @@ -{-# 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) 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) -- 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,7 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, CPP #-} -#if __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Unsafe #-} -#endif {-# OPTIONS_HADDOCK not-home #-} -- | -- Copyright : 2010-2011 Simon Meier, 2010 Jasper van der Jeugt 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 +{-# LANGUAGE MagicHash #-} -- | -- Copyright : (c) 2011 Simon Meier -- License : BSD3-style (see LICENSE) @@ -24,57 +22,42 @@ , 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) -#else -import Foreign -#endif +import GHC.Exts (Addr#, Ptr(..)) -- 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 = EncodingTable + "000102030405060708090a0b0c0d0e0f\ + \101112131415161718191a1b1c1d1e1f\ + \202122232425262728292a2b2c2d2e2f\ + \303132333435363738393a3b3c3d3e3f\ + \404142434445464748494a4b4c4d4e4f\ + \505152535455565758595a5b5c5d5e5f\ + \606162636465666768696a6b6c6d6e6f\ + \707172737475767778797a7b7c7d7e7f\ + \808182838485868788898a8b8c8d8e8f\ + \909192939495969798999a9b9c9d9e9f\ + \a0a1a2a3a4a5a6a7a8a9aaabacadaeaf\ + \b0b1b2b3b4b5b6b7b8b9babbbcbdbebf\ + \c0c1c2c3c4c5c6c7c8c9cacbcccdcecf\ + \d0d1d2d3d4d5d6d7d8d9dadbdcdddedf\ + \e0e1e2e3e4e5e6e7e8e9eaebecedeeef\ + \f0f1f2f3f4f5f6f7f8f9fafbfcfdfeff"# + -- | 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,5 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif -- | -- Copyright : (c) 2010 Simon Meier -- 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,851 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns, MagicHash #-} +-- | +-- 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(..)) + +-- See Data.ByteString.Builder.RealFloat.TableGenerator for a high-level +-- explanation of the ryu algorithm + +-- | Table of 2^k / 5^q + 1 +-- Byte-swapped version of +-- > fmap (finv double_pow5_inv_bitcount) [0..double_max_inv_split] +double_pow5_inv_split :: Addr +double_pow5_inv_split = Addr + "\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\ + \\x9a\x99\x99\x99\x99\x99\x99\x99\x99\x99\x99\x99\x99\x99\x99\x19\ + \\x15\xae\x47\xe1\x7a\x14\xae\x47\xe1\x7a\x14\xae\x47\xe1\x7a\x14\ + \\xde\x24\x06\x81\x95\x43\x8b\x6c\xe7\xfb\xa9\xf1\xd2\x4d\x62\x10\ + \\x96\xd4\x09\x68\x22\x6c\x78\x7a\xa5\x2c\x43\x1c\xeb\xe2\x36\x1a\ + \\xab\x43\x6e\x86\x1b\xf0\xf9\x61\x84\xf0\x68\xe3\x88\xb5\xf8\x14\ + \\x22\x36\x58\x38\x49\xf3\xc7\xb4\x36\x8d\xed\xb5\xa0\xf7\xc6\x10\ + \\x6a\x23\x8d\xc0\x0e\x52\xa6\x87\x57\x48\xaf\xbc\x9a\xf2\xd7\x1a\ + \\x88\x4f\xd7\x66\xa5\x41\xb8\x9f\xdf\x39\x8c\x30\xe2\x8e\x79\x15\ + \\x07\xa6\x12\x1f\x51\x01\x2d\xe6\xb2\x94\xd6\x26\xe8\x0b\x2e\x11\ + \\xa4\x09\x51\xcb\x81\x68\xae\xd6\xb7\xba\xbd\xd7\xd9\xdf\x7c\x1b\ + \\xea\x3a\xa7\xa2\x34\xed\xf1\xde\x5f\x95\x64\x79\xe1\x7f\xfd\x15\ + \\xbb\xc8\x85\xe8\xf6\xf0\x27\x7f\x19\x11\xea\x2d\x81\x99\x97\x11\ + \\xf8\x0d\xd6\x40\xbe\xb4\x0c\x65\xc2\x81\x76\x49\x68\xc2\x25\x1c\ + \\x93\x71\xde\x33\x98\x90\x70\xea\x01\x9b\x2b\xa1\x86\x9b\x84\x16\ + \\x43\xc1\x7e\x29\xe0\xa6\xf3\x21\x9b\x15\x56\xe7\x9e\xaf\x03\x12\ + \\x37\x35\x31\x0f\xcd\xd7\x85\x69\x2b\xbc\x89\xd8\x97\xb2\xd2\x1c\ + \\xf9\x90\x5a\x3f\xd7\xdf\x37\x21\x89\x96\xd4\x46\x46\xf5\x0e\x17\ + \\xfa\x73\x48\xcc\x45\xe6\x5f\xe7\xa0\xab\x43\xd2\xd1\x5d\x72\x12\ + \\x5d\x86\x0d\x7a\x3c\x3d\x66\xa5\x34\xac\xd2\xb6\x4f\xc9\x83\x1d\ + \\xb1\x9e\xd7\x94\x63\x97\x1e\x51\x5d\x23\x42\x92\x0c\xa1\x9c\x17\ + \\xc1\x4b\x79\xdd\x82\xdf\x7e\xda\x7d\x4f\x9b\x0e\x0a\xb4\xe3\x12\ + \\x68\xac\x5b\x62\xd1\x98\x64\x2a\x96\xe5\x5e\x17\x10\x20\x39\x1e\ + \\x53\xf0\xe2\x81\xa7\xe0\xb6\xee\x44\x51\xb2\x12\x40\xb3\x2d\x18\ + \\xa9\x26\x4f\xce\x52\x4d\x92\x58\x6a\xa7\x8e\xa8\x99\xc2\x57\x13\ + \\x41\xa4\x7e\xb0\xb7\x7b\x50\x27\xaa\xd8\x7d\xda\xf5\xd0\xf2\x1e\ + \\x34\x50\x65\xc0\x5f\xc9\xa6\x52\xbb\x13\xcb\xae\xc4\x40\xc2\x18\ + \\x90\xa6\xea\x99\x4c\xd4\xeb\x0e\xc9\x0f\x3c\xf2\x36\x9a\xce\x13\ + \\x80\x0a\x11\xc3\xad\x53\x79\xb1\x41\x19\x60\x50\xbe\xf6\xb0\x1f\ + \\x67\x08\x74\x02\x8b\xdc\x2d\xc1\x67\x47\xb3\xa6\xfe\x5e\x5a\x19\ + \\x52\xa0\x29\x35\x6f\xb0\x24\x34\x86\x9f\xc2\xeb\xfe\x4b\x48\x14\ + \\xdb\x19\xee\x90\xf2\x59\x1d\x90\x9e\x7f\x68\x89\x65\xd6\x39\x10\ + \\x5f\x29\xb0\xb4\x1d\xc3\xfb\x4c\x97\x32\xa7\xa8\xd5\x23\xf6\x19\ + \\xb2\xba\x59\x5d\xb1\x35\x96\x3d\xac\x5b\x1f\xba\x77\xe9\xc4\x14\ + \\x28\x62\xe1\x7d\x27\x5e\xab\x97\x56\x49\x4c\xfb\x92\x87\x9d\x10\ + \\x0d\x9d\x68\xc9\xd8\xc9\xab\xf2\xf0\x0e\x7a\xf8\xb7\xa5\x95\x1a\ + \\x3e\x17\xba\x3a\x7a\xa1\xbc\x5b\x5a\x72\x2e\x2d\x93\x84\x44\x15\ + \\xcb\x45\xfb\x2e\xc8\x1a\xca\xaf\xae\x8e\x8b\x8a\x42\x9d\x03\x11\ + \\x45\x09\x92\xb1\xa6\xf7\xdc\xb2\x4a\xe4\x78\xaa\x9d\xfb\x38\x1b\ + \\x04\xa1\x41\xc1\xeb\x92\x7d\xf5\x6e\x83\x2d\x55\xb1\x2f\xc7\x15\ + \\x03\xb4\x67\x67\x89\x75\x64\xc4\x58\x9c\x57\x77\x27\x26\x6c\x11\ + \\xd2\xec\xa5\xd8\xdb\x88\x6d\x6d\xf4\xc6\x25\xf2\x0b\x3d\xe0\x1b\ + \\xdb\x23\xeb\x46\x16\x07\xbe\x8a\xc3\x38\x1e\x28\xa3\xfd\x4c\x16\ + \\x49\xb6\x55\xd2\x11\x6c\xfe\x6e\x9c\x60\x4b\x53\x4f\x31\xd7\x11\ + \\x0e\x8a\xef\xb6\x4f\x13\x97\xb1\x60\x67\x45\x85\x18\x82\x8b\x1c\ + \\xa5\xa1\xbf\xf8\x72\x0f\xac\x27\x1a\xb9\x6a\x37\xad\x01\xd6\x16\ + \\x1e\x4e\x99\x60\xc2\x72\x56\xb9\xe1\x60\x55\x2c\x24\xce\x44\x12\ + \\x95\x16\xc2\xcd\x03\x1e\x57\xf5\x35\xce\xbb\x13\x6d\xe3\x3a\x1d\ + \\xab\xab\x01\x0b\x03\x18\xac\x2a\x2b\xd8\x2f\x76\x8a\x4f\x62\x17\ + \\x56\x89\x34\x6f\x02\xe0\xbc\xbb\x55\x13\xf3\xc4\x6e\x0c\xb5\x12\ + \\x89\xa8\xed\xb1\xd0\xcc\xc7\x92\xef\x1e\xb8\xd4\x4a\x7a\xee\x1d\ + \\x07\xba\x57\x8e\x40\x0a\xd3\xdb\xf2\x4b\x93\x10\x6f\xfb\xf1\x17\ + \\x06\xc8\xdf\x71\x00\xd5\xa8\x7c\xf5\x6f\x0f\xda\x58\xfc\x27\x13\ + \\xd6\x0c\x66\xe9\x33\xbb\xa7\xfa\xbb\x4c\xb2\x29\x8e\x60\xa6\x1e\ + \\x11\xd7\x84\x87\x29\xfc\x52\x95\xc9\xa3\x8e\x54\x0b\x1a\x85\x18\ + \\x0e\xac\xd0\xd2\xba\xc9\xa8\xaa\x07\x83\xd8\x76\x6f\xae\x9d\x13\ + \\xe3\xac\x1a\x1e\x5e\xdc\xda\xdd\xa5\xd1\xc0\x57\xb2\xb0\x62\x1f\ + \\x4f\x8a\x48\x4b\x4b\xb0\x48\x7e\x51\x41\x9a\xac\x8e\xc0\x1b\x19\ + \\xd9\xa1\xd3\xd5\xd5\x59\x6d\xcb\xda\xcd\xe1\x56\xa5\x33\x16\x14\ + \\x7b\x81\xdc\x77\x11\x7b\x57\x3c\xe2\xd7\xe7\xab\xea\xc2\x11\x10\ + \\x2a\xcf\x60\x59\x82\x5e\xf2\xc6\x36\x26\xa6\xac\xaa\x04\xb6\x19\ + \\xbb\xa5\x80\x47\x68\x18\xf5\x6b\xc5\x51\xeb\x56\x55\x9d\x91\x14\ + \\x96\x84\x00\x06\xed\x79\x2a\x23\xd1\xa7\x22\xdf\xdd\x7d\x74\x10\ + \\x56\x07\x34\xa3\xe1\x8f\xdd\xd1\x81\x0c\xd1\x31\x96\xfc\x53\x1a\ + \\x45\x6c\xf6\xe8\x1a\x73\xe4\xa7\x34\x3d\xa7\xf4\x44\xfd\x0f\x15\ + \\x9e\x56\xf8\x53\xe2\x28\x1d\x53\x5d\x97\x52\x5d\x6a\x97\xd9\x10\ + \\x62\x57\x8d\xb9\x03\xdb\x61\xeb\x2e\xf2\x50\x95\x10\xbf\xf5\x1a\ + \\xe8\x45\xa4\xc7\xcf\x48\x4e\xbc\x58\x5b\xda\xdd\xa6\x65\x91\x15\ + \\x20\x6b\x83\x6c\xd9\xd3\x71\x63\xad\xe2\xe1\x17\x1f\x1e\x41\x11\ + \\xcd\x11\x9f\xad\x28\x86\x1c\x9f\x48\x04\x03\xf3\x64\x63\x9b\x1b\ + \\x0b\xdb\x18\xbe\x53\x6b\xb0\xe5\x06\x9d\x35\x8f\x1d\xe9\x15\x16\ + \\xa2\x15\x47\xcb\x0f\x89\xf3\xea\x6b\x4a\x91\x72\xe4\x20\xab\x11\ + \\x37\xbc\x71\x78\x4c\xdb\xb8\x44\x46\xaa\x1b\x84\x6d\x01\x45\x1c\ + \\x5f\x63\xc1\xc6\xd6\x15\xc7\x03\x05\x55\x49\x03\xbe\x9a\x9d\x16\ + \\x19\xe9\xcd\x6b\x45\xde\x38\x36\x37\x77\x07\x69\xfe\xae\x17\x12\ + \\xc1\x41\x16\x46\xa2\x63\xc1\x56\x58\x58\x72\x0e\x97\xb1\xf2\x1c\ + \\xce\x67\xab\xd1\x81\x1c\x01\xdf\x79\x13\xf5\x71\x12\x8e\x28\x17\ + \\xa5\xec\x55\x41\xce\x16\x34\x7f\x61\xdc\x90\xc1\x0e\xd8\x86\x12\ + \\x6e\x47\x56\x35\x7d\x24\x20\x65\x02\xc7\xe7\x68\xe4\x8c\xa4\x1d\ + \\x25\x39\x78\xf7\x30\x1d\x80\xea\x01\x6c\xb9\x20\x1d\xd7\xb6\x17\ + \\x84\xfa\x2c\xf9\xf3\xb0\x99\xbb\x34\x23\x61\x4d\x17\xac\xf8\x12\ + \\x39\xf7\x47\x28\x53\x4e\x5c\x5f\x54\x38\x68\x15\xf2\xac\x5a\x1e\ + \\x2e\x2c\xd3\xb9\x75\x0b\x7d\x7f\x43\x60\x53\x44\x5b\x8a\x48\x18\ + \\x58\x23\xdc\xc7\xf7\xd5\x30\x99\xcf\x19\xa9\x36\x7c\x3b\x6d\x13\ + \\x26\xd2\xf9\x72\x8c\x89\xb4\x8e\xb2\x8f\x0e\xf1\xf9\x2b\x15\x1f\ + \\xb8\x41\x2e\x8f\xa3\x07\x2a\x72\x28\xa6\x0b\xf4\xc7\xbc\xdd\x18\ + \\xfa\x9a\xbe\xa5\x4f\x39\xbb\xc1\x86\x1e\xd6\x5c\x06\x97\xe4\x13\ + \\xf6\xf7\x30\x09\x19\xc2\x5e\x9c\xd7\x30\xf0\xfa\xd6\x24\xd4\x1f\ + \\xf8\x5f\x5a\x07\x14\x68\xe5\x49\x79\x8d\x26\x2f\xdf\x83\x76\x19\ + \\x60\xe6\xe1\x05\x10\x20\x51\x6e\xc7\x0a\x52\xbf\xe5\xcf\x5e\x14\ + \\x1a\x85\x81\xd1\x0c\x80\xda\xf1\x05\x6f\x0e\x99\x84\xd9\x4b\x10\ + \\xf5\xd4\x68\x82\x14\x00\xc4\x4f\xd6\xe4\xe3\xf4\xa0\xf5\x12\x1a\ + \\x2b\x77\xed\x01\xaa\x99\x69\xd9\x11\xb7\x1c\xf7\xb3\xf7\xdb\x14\ + \\xbc\xc5\x8a\x01\x88\x14\xee\xad\x74\x92\xb0\xc5\x5c\xf9\xaf\x10\ + \\x2c\x09\xde\x68\xa6\xed\x7c\x49\x54\xea\x80\x6f\x94\x28\xb3\x1a\ + \\x24\xd4\xe4\x53\xb8\x57\xca\x3a\x10\x55\x9a\xbf\x76\x20\x5c\x15\ + \\x83\x76\x1d\x43\x60\x79\x3b\x62\x73\xaa\xae\xff\x5e\x80\x16\x11\ + \\x9e\xbd\xc8\xd1\x66\xf5\x2b\x9d\xb8\x10\xb1\x32\xcb\x33\x57\x1b\ + \\x7f\x64\x6d\x41\x52\xc4\xbc\x7d\x60\x0d\xf4\x8e\xa2\x5c\xdf\x15\ + \\xcc\xb6\x8a\x67\xdb\x69\xfd\xca\xe6\x3d\xc3\xd8\x4e\x7d\x7f\x11\ + \\xdf\x8a\x77\x72\xc5\x0f\x2f\xab\xd7\x2f\x05\x8e\xe4\x2e\xff\x1b\ + \\x80\xd5\x92\x5b\x04\x73\xf2\x88\xac\x8c\x6a\x3e\x1d\xbf\x65\x16\ + \\x66\x44\x42\x49\xd0\x28\xf5\xd3\x56\x3d\x55\x98\x4a\xff\xea\x11\ + \\xa3\xa0\x03\x42\x4d\x41\x88\xb9\x57\x95\xbb\xf3\x10\x32\xab\x1c\ + \\xe9\xe6\x02\x68\xd7\xcd\x39\x61\x79\x77\xfc\xc2\x40\x5b\xef\x16\ + \\x54\x52\x02\x20\x79\x71\x61\xe7\x2d\xf9\xc9\x68\xcd\x15\x59\x12\ + \\x86\x50\x9d\x99\x8e\xb5\x68\xa5\x7c\x5b\x76\x74\x15\x56\x5b\x1d\ + \\xd2\xa6\x4a\xe1\x3e\x91\x20\x51\xfd\x15\xc5\xf6\xdd\x44\x7c\x17\ + \\x0e\x1f\xa2\x1a\xff\x40\x4d\xa7\xca\x44\x37\x92\xb1\xd0\xc9\x12\ + \\x4a\xcb\x69\xf7\x64\xce\xae\x0b\x11\x6e\x58\x50\x4f\xb4\x0f\x1e\ + \\x3b\x3c\xee\xc5\x50\xd8\x8b\x3c\xa7\xf1\x79\x73\x3f\x90\x0c\x18\ + \\xc9\xc9\xf1\x37\xda\x79\x09\xca\x85\xf4\xc7\xc2\x32\x40\x3d\x13\ + \\xdb\x42\xe9\xbf\xf6\xc2\xa8\xa9\x6f\xba\x0c\x9e\xb7\x66\xc8\x1e\ + \\xe3\x9b\xba\xcc\x2b\xcf\x53\x21\x26\x95\x70\x7e\x2c\x52\xa0\x18\ + \\x82\x49\x95\x70\x89\x72\xa9\x1a\xb8\xdd\x26\x65\xf0\x74\xb3\x13\ + \\x9d\x75\x88\x1a\x0f\x84\x75\xf7\x8c\x2f\x3e\x08\xe7\x87\x85\x1f\ + \\x17\x5e\xa0\x7b\x72\x36\x91\x5f\x0a\x26\x98\x06\xec\x9f\x37\x19\ + \\xdf\xe4\x19\x96\x5b\xf8\x40\x19\xd5\x84\x46\x05\xf0\x7f\x2c\x14\ + \\x4c\xea\x47\xab\xaf\xc6\x00\xe1\x10\x37\x05\xd1\x8c\x99\x23\x10\ + \\x47\xdd\x3f\x45\x4c\xa4\x67\xce\xe7\x24\xd5\xb4\x47\x8f\xd2\x19\ + \\x06\xb1\xcc\x9d\xd6\xe9\x52\xd8\x1f\xb7\xdd\xc3\x9f\x72\xa8\x14\ + \\x38\x27\x0a\x4b\x45\xee\xdb\x79\x19\x2c\x7e\x69\x19\xc2\x86\x10\ + \\x59\xd8\xa9\x11\xa2\xe3\x5f\x29\x8f\x46\x30\x0f\x8f\x36\x71\x1a\ + \\x7a\x13\xbb\xa7\x81\x1c\xb3\xba\xa5\x6b\xf3\xd8\xd8\x5e\x27\x15\ + \\x2f\xa9\x95\xec\x9a\xe3\x28\x62\x51\x89\x8f\xad\xe0\x4b\xec\x10\ + \\x17\x75\xef\xe0\xf7\x38\x0e\x9d\xe8\x0e\x4c\xaf\x9a\xac\x13\x1b\ + \\x79\x2a\x59\x1a\x93\x2d\xd8\xb0\x53\x72\xd6\x25\xe2\x56\xa9\x15\ + \\x2e\x55\x47\x48\x0f\xbe\x79\x8d\xdc\xc1\xde\xb7\x81\x45\x54\x11\ + \\x7c\xbb\x0b\xda\x7e\x96\x8f\x15\x94\x9c\x97\x8c\xcf\x08\xba\x1b\ + \\x97\x2f\xd6\x14\xff\x11\xa6\x77\x76\xb0\xdf\xd6\x72\x6d\x2e\x16\ + \\x79\x8c\xde\x43\xff\xa7\x51\xf9\x91\xf3\xb2\x78\xf5\xbd\xbe\x11\ + \\x8e\xad\xfd\xd2\xfe\x3f\x1c\xc2\x1c\xec\xb7\x5a\x22\x63\x64\x1c\ + \\xd8\x8a\x64\x42\x32\x33\xb0\x01\x17\xf0\x5f\x15\xb5\xb5\xb6\x16\ + \\x46\xa2\x83\x9b\x8e\xc2\x59\x01\xac\x59\xe6\xdd\x90\xc4\x2b\x12\ + \\xa3\x03\x39\x5f\x17\x04\xf6\xce\xac\xc2\xa3\xfc\x1a\xd4\x12\x1d\ + \\x83\x9c\x2d\x4c\xac\x69\x5e\x72\xbd\x9b\x1c\xca\x48\x43\x42\x17\ + \\x9c\xe3\x8a\xd6\x89\x54\x18\xf5\xfd\xe2\x16\x08\x07\x69\x9b\x12\ + \\xc6\x05\xab\xbd\x0f\x54\x8d\xee\x2f\x6b\xf1\x0c\xd8\x74\xc5\x1d\ + \\x05\x6b\x22\xfe\x72\x76\xd7\xbe\x8c\x22\xc1\x70\x46\x2a\xd1\x17\ + \\x04\xbc\x4e\xcb\x28\xc5\x12\xff\xd6\x4e\x67\x8d\x6b\xbb\x0d\x13\ + \\xa0\xf9\x7d\x78\x74\x3b\x51\xcb\x24\x7e\xd8\x7b\x12\x5f\x7c\x1e\ + \\x4d\x61\xfe\xf9\x29\xc9\x0d\x09\xb7\x31\xad\xfc\x41\x7f\x63\x18\ + \\x0a\x81\xcb\x94\x21\xd4\xd7\xa0\xc5\x27\x24\xca\x34\xcc\x82\x13\ + \\x77\xce\x78\x54\xcf\xb9\xbf\x67\x6f\x0c\x6d\x43\x21\xad\x37\x1f\ + \\xf9\x71\x2d\xdd\xa5\x94\xcc\x1f\x59\x70\x8a\xcf\x4d\x57\xf9\x18\ + \\xc7\xf4\xbd\x7d\x51\xdd\xd6\x7f\x7a\xf3\xa1\x3f\x3e\xac\xfa\x13\ + \\x0b\xee\x2f\xc9\xe8\x2e\xbe\xff\xc3\xb8\x9c\x32\xfd\x79\xf7\x1f\ + \\xd6\x24\xf3\xa0\x20\xbf\x31\x66\x36\xfa\x16\xc2\xfd\xc7\x92\x19\ + \\x78\x1d\x5c\x1a\x1a\xcc\x27\xb8\x5e\xfb\xab\x01\xcb\x6c\x75\x14\ + \\x60\xe4\x7c\x7b\xae\x09\x53\x93\x18\xc9\xbc\x67\xa2\xf0\x5d\x10\ + \\x99\xa0\x94\xc5\xb0\x42\xeb\x1e\xf4\x74\x94\x3f\x6a\xe7\x2f\x1a\ + \\xe1\xe6\x76\x04\x27\x02\x89\xe5\x5c\x2a\xdd\x32\x88\x1f\xf3\x14\ + \\xe7\xeb\x2b\x9d\x85\xce\xa0\xb7\xb0\xee\xb0\x28\xa0\x7f\xc2\x10\ + \\xd8\xdf\xdf\x61\x6f\x4a\x01\x59\xb4\x4a\x4e\x74\x33\xcc\xd0\x1a\ + \\xad\x4c\xe6\xe7\x25\xd5\xcd\xe0\x29\xa2\x3e\x90\x8f\xd6\x73\x15\ + \\xf1\xd6\x51\x86\x51\x77\x71\x4d\xee\xb4\xcb\xd9\x72\x78\x29\x11\ + \\xe8\x57\xe9\xd6\xe8\xbe\xe8\x7b\xb0\x54\xac\x8f\x84\x8d\x75\x1b\ + \\x20\x13\x21\xdf\x53\x32\xba\xfc\x59\xdd\x89\x0c\x6a\xa4\xf7\x15\ + \\x80\x42\xe7\x18\x43\x28\xc8\x63\xae\x4a\x6e\x70\xee\xe9\x92\x11\ + \\x66\x6a\xd8\x27\x38\x0d\x0d\x06\x17\x11\x4a\x1a\x17\x43\x1e\x1c\ + \\xeb\x21\xad\xec\x2c\xa4\x3d\x6b\x12\x74\x6e\x7b\x12\x9c\x7e\x16\ + \\x56\x4e\x57\xbd\xf0\x1c\xfe\x88\xdb\x5c\x58\xfc\x41\xe3\xfe\x11\ + \\x23\x4a\x25\x62\xb4\x94\x96\x41\x5f\x61\x8d\x60\x36\x05\xcb\x1c\ + \\xe9\xd4\x1d\xe8\x29\xaa\xab\x67\x7f\xe7\x3d\x4d\xf8\xd0\x08\x17\ + \\x87\xdd\x17\x20\xbb\x21\x56\xb9\x32\xb9\x64\xd7\xf9\x73\x6d\x12\ + \\xa5\x95\x8c\x66\x2b\x69\x23\xc2\xea\xc1\x3a\xf2\xc2\xec\x7b\x1d\ + \\x1d\xde\xd6\x1e\x89\xba\x82\xce\xbb\x34\x62\x5b\x02\x57\x96\x17\ + \\x18\x18\xdf\x4b\x07\x62\x35\xa5\xfc\xf6\xb4\xe2\x01\xac\xde\x12\ + \\x59\xf3\x64\x79\xd8\x9c\x88\x3b\x94\xf1\x87\x37\x36\x13\x31\x1e\ + \\xe1\xf5\x83\xc7\x46\x4a\x6d\xfc\xdc\x5a\x06\xc6\x91\x42\x27\x18\ + \\x1a\x2b\x03\x06\x9f\x6e\x57\x30\x17\xaf\x9e\xd1\xa7\x9b\x52\x13\ + \\x90\xde\xd1\x3c\xcb\x7d\x25\x1a\x25\x18\x31\x1c\xa6\x92\xea\x1e\ + \\x40\xe5\xa7\x30\x3c\xfe\x1d\x48\xb7\x79\x5a\xe3\x84\xa8\xbb\x18\ + \\x00\x51\x86\xc0\xc9\x31\x4b\xd3\xc5\xc7\xae\x82\x9d\x53\xc9\x13\ + \\xcd\xb4\xa3\xcd\x42\xe9\x11\x52\x09\xa6\x17\xd1\xc8\x85\xa8\x1f\ + \\xa4\x90\x1c\x3e\x02\x21\xdb\x74\x07\xb8\xdf\x40\x3a\x9e\x53\x19\ + \\x50\x0d\x4a\xcb\x01\xb4\x15\xf7\x05\x60\x19\x67\xfb\xe4\x42\x14\ + \\xa7\x0a\x08\x09\x9b\x29\xde\xf8\x37\xb3\x7a\x52\xfc\x83\x35\x10\ + \\xd7\xdd\x0c\xa8\x91\x42\x30\x8e\x59\xb8\x2a\xb7\x93\x39\xef\x19\ + \\x13\x4b\x0a\x20\x0e\x02\x8d\x3e\xe1\xf9\xee\xf8\x42\x61\xbf\x14\ + \\x0f\x3c\x08\x80\x3e\x9b\x3d\x65\xe7\xc7\x58\xfa\x9b\x1a\x99\x10\ + \\xe4\x2c\x0d\x00\x64\xf8\xc8\x6e\xa5\x0c\x8e\x90\xf9\x90\x8e\x1a\ + \\xea\x23\xa4\x99\xe9\xf9\xd3\x8b\xb7\xa3\x71\x40\x61\xda\x3e\x15\ + \\xbb\x1c\x50\xe1\xba\x94\xa9\x3c\xf9\x82\xf4\x99\x1a\x15\xff\x10\ + \\x2b\x61\xb3\x9b\xc4\xba\x75\xc7\x8e\xd1\x20\xc3\x5d\xbb\x31\x1b\ + \\x89\x1a\x29\x16\x6a\x95\xc4\xd2\x0b\x0e\xe7\x68\xb1\x62\xc1\x15\ + \\xa1\x7b\xba\x11\x88\x77\xd0\xdb\x6f\x3e\x1f\x87\x27\x82\x67\x11\ + \\x9b\x92\x5d\x1c\x40\xbf\x80\x2c\xe6\x63\x98\x3e\x3f\xd0\xd8\x1b\ + \\x49\x75\xe4\x49\x33\xcc\x33\xbd\x51\xb6\x46\x65\xff\x0c\x47\x16\ + \\xd4\x5d\x50\x6e\x8f\xd6\x8f\xca\xa7\x5e\x05\x51\xcc\x70\xd2\x11\ + \\x53\xc9\xb3\xe3\x4b\x57\x19\x44\xd9\xfd\x6e\x4e\xad\xe7\x83\x1c\ + \\xa9\x3a\xf6\x82\x09\x79\x47\x03\xe1\x97\x25\xa5\x8a\xec\xcf\x16\ + \\xba\xfb\xc4\x68\xd4\x60\x6c\xcf\x80\x79\x84\xea\x6e\xf0\x3f\x12\ + \\x2a\xf9\x07\x0e\x87\x34\x7a\xe5\x9a\xf5\xd3\x10\x4b\x1a\x33\x1d\ + \\x22\x94\x39\x0b\x6c\x90\x2e\x51\xe2\x2a\x43\xda\x08\x15\x5c\x17\ + \\xb5\xa9\xc7\xd5\xbc\xa6\x8b\xda\x81\x55\xcf\xe1\xd3\x10\xb0\x12\ + \\x87\x0f\xd9\x22\x2e\x71\xdf\x90\x9c\x55\xe5\x02\x53\x81\xe6\x1d\ + \\x6c\x0c\x14\x4f\x8b\x5a\x4c\xda\x16\xde\x1d\xcf\xa8\x9a\xeb\x17\ + \\x8a\xa3\xa9\xa5\xa2\x7b\xa3\xae\x78\x7e\xb1\xa5\x20\xe2\x22\x13\ + \\xa9\x05\xa9\xa2\x6a\x5f\xd2\x7d\x27\x97\xb5\xa2\x9a\x36\x9e\x1e\ + \\x54\xd1\x20\x82\x88\x7f\xdb\x97\x1f\xac\xf7\x4e\x15\x92\x7e\x18\ + \\x77\xa7\x80\xce\x06\x66\x7c\x79\x4c\x23\xc6\xd8\xdd\x74\x98\x13\ + \\xf1\x0b\x01\xe4\x0a\x70\x2d\x8f\xad\x6b\xa3\x27\x96\x54\x5a\x1f\ + \\x5a\xd6\x00\x50\xa2\x59\x24\x0c\xbe\xef\xb5\x1f\x78\x10\x15\x19\ + \\x15\x45\x9a\xd9\x81\x14\x1d\x70\xfe\xf2\xf7\xb2\xf9\xd9\x10\x14\ + \\x77\x6a\x7b\x14\x9b\x43\x17\xc0\xfe\x5b\xc6\x28\x2e\x7b\x0d\x10\ + \\xf2\x43\x92\xed\xc4\x05\xf2\xcc\xca\x2c\x0a\x0e\x7d\x2b\xaf\x19\ + \\xc2\x9c\x0e\xbe\xd0\x37\x5b\x0a\x6f\xbd\xa1\x71\xca\x22\x8c\x14\ + \\xce\xe3\x3e\xcb\x73\xf9\x48\x08\x8c\x97\xb4\x27\xd5\x1b\x70\x10\ + \\xb0\x9f\x64\x78\xec\x5b\x0e\xda\xac\x25\x54\x0c\x55\xf9\x4c\x1a\ + \\xc0\x7f\x50\x60\xf0\xaf\x3e\x7b\xbd\xb7\xa9\xd6\x10\x61\x0a\x15\ + \\x33\x66\x40\x80\xf3\xbf\xcb\x95\x97\x2c\xee\xde\x73\x1a\xd5\x10\ + \\x52\x70\xcd\x66\x52\x66\xac\xef\x58\x47\xb0\x64\xb9\x90\xee\x1a\ + \\xdb\x59\xa4\xb8\x0e\x85\x23\x26\x47\x6c\xf3\xb6\xfa\xa6\x8b\x15\ + \\x49\xae\xb6\x93\xd8\xd0\x82\x1e\x6c\x23\x29\x5f\x95\x85\x3c\x11\ + \\x75\xb0\x8a\x1f\xf4\x1a\x9e\xfd\xac\x38\xa8\xfe\xee\x08\x94\x1b\ + \\xf7\x59\xd5\xb2\x29\xaf\xb1\x97\xbd\x93\x86\x98\x25\x07\x10\x16\ + \\x2c\x7b\x77\xf5\xba\x25\x8e\xac\x97\xdc\x9e\x13\x1e\x6c\xa6\x11\ + \\x13\xc5\x58\x22\x2b\x09\x7d\x7a\xbf\x2d\xfe\xb8\xc9\x79\x3d\x1c\ + \\x76\x6a\xad\x4e\xef\xa0\xfd\x61\xcc\x57\xcb\x60\xa1\x94\x97\x16\ + \\xc5\xee\xbd\x0b\x59\x1a\xfe\xe7\x09\x13\x09\xe7\x4d\xdd\x12\x12\ + \\x3a\xb1\xfc\x45\x5b\x5d\x63\xa6\xdc\x84\x0e\xd8\xaf\xfb\xea\x1c\ + \\xc8\x8d\x30\x6b\xaf\x4a\x1c\x85\xb0\xd0\x3e\x13\xf3\x62\x22\x17\ + \\xd4\xd7\x26\xbc\xf2\x6e\xe3\xd0\x26\xda\xcb\x75\xc2\xe8\x81\x12\ + \\x86\x8c\xa4\xc6\xea\x17\x9f\xb4\xd7\x29\x46\x89\x9d\xa7\x9c\x1d\ + \\x6b\x70\x50\x05\xef\xdf\x18\x2a\x46\xee\x04\xa1\x17\x86\xb0\x17\ + \\x89\xf3\xd9\x9d\x25\xb3\xe0\x54\x6b\x8b\x9d\x4d\x79\x9e\xf3\x12\ + \\x74\x52\xf6\x62\x6f\xeb\xcd\x87\x78\x45\x2f\x7c\x28\x97\x52\x1e\ + \\x5d\xa8\x5e\x82\xbf\x22\x0b\xd3\xc6\x6a\xbf\xc9\x86\x12\x42\x18\ + \\xe4\xb9\x4b\x68\xcc\x1b\x3c\x0f\x9f\x88\xff\x3a\xd2\x0e\x68\x13\ + \\x6d\x29\x79\x40\x7a\x2c\x60\x18\x98\xda\x98\x91\x83\xe4\x0c\x1f\ + \\x24\x21\x94\x33\xc8\x56\xb3\x46\x13\xe2\x13\x0e\x36\x1d\xd7\x18\ + \\xb6\x4d\x43\x29\xa0\x78\x8f\x38\xdc\xb4\xdc\xa4\x91\x4a\xdf\x13\ + \\x8a\xaf\x6b\xa8\x66\x27\x7f\x5a\x60\x21\x61\xa1\x82\xaa\xcb\x1f\ + \\xa2\xbf\xef\xb9\xeb\x85\x32\x15\x4d\xb4\x4d\xb4\x9b\xbb\x6f\x19\ + \\x4e\x99\x8c\x61\x89\xd1\x8e\xaa\x3d\x90\xa4\xf6\xe2\x62\x59\x14\ + \\x0c\xe1\xd6\x1a\xa1\xa7\xd8\xee\xca\xd9\xb6\x2b\x4f\x82\x47\x10\ + \\x45\x9b\x24\x5e\x9b\x72\x27\x7e\x11\xf6\x8a\xdf\xb1\x03\x0c\x1a\ + \\x04\x49\x1d\x18\x49\xf5\x85\xfe\x0d\xf8\x3b\x19\x5b\x69\xd6\x14\ + \\xd0\xa0\x4a\x13\xd4\x5d\x9e\xcb\xa4\xf9\x2f\x14\x7c\x87\xab\x10\ + \\x4d\x01\x11\x52\x53\xc9\x63\xdf\x3a\x5c\xe6\xb9\xf9\x0b\xac\x1a\ + \\x71\x67\xda\x74\x0f\xa1\x1c\x19\x2f\xb0\x1e\xfb\xfa\x6f\x56\x15\ + \\xc1\x52\x48\x2a\xd9\x80\xb0\xad\x25\xc0\x4b\x2f\x2f\xf3\x11\x11\ + \\x34\x51\x0d\xaa\x8e\x34\xe7\x15\x09\xcd\x12\xb2\x7e\xeb\x4f\x1b\ + \\xc4\x0d\x71\xee\x3e\x5d\x1f\xab\x6d\x0a\x0f\x28\x32\x89\xd9\x15\ + \\x9d\xa4\x8d\x8b\x65\x17\x19\xbc\x57\x08\x0c\x20\x28\xd4\x7a\x11\ + \\x94\x3a\x7c\x12\x3c\xf2\xf4\x2c\x59\x0d\xe0\xcc\xd9\xb9\xf7\x1b\ + \\x43\x95\x96\xdb\xfc\xf4\xc3\xf0\xe0\x3d\xb3\x70\xe1\xc7\x5f\x16\ + \\x03\x11\x12\x16\x97\x5d\x36\x5a\x1a\xcb\xf5\x26\x81\x39\xe6\x11\ + \\x04\xe8\x1c\xf0\x24\xfc\x56\x90\x90\xde\x22\x0b\x35\x8f\xa3\x1c\ + \\xd0\xec\xe3\x8c\x1d\x30\xdf\xd9\xa6\x4b\x82\xa2\x5d\x3f\xe9\x16\ + \\xda\x23\x83\x3d\xb1\x59\x7f\xe1\xeb\xa2\xce\x4e\xb1\x32\x54\x12\ + \\x5c\x39\x38\x2f\xb5\xc2\xcb\x68\x79\xd1\x7d\xe4\x4e\x84\x53\x1d\ + \\xe3\x2d\x60\xbf\x5d\x35\xd6\x53\x94\xa7\x64\x50\x72\x03\x76\x17\ + \\x1c\x8b\xe6\x65\xb1\x2a\x78\xa9\x76\xec\xb6\xa6\x8e\xcf\xc4\x12\ + \\xfa\x44\xd7\x6f\xb5\xaa\x26\x0f\xf1\x13\x8b\xd7\x7d\xb2\x07\x1e\ + \\x62\x6a\xdf\xbf\x2a\x22\x52\x3f\x27\x43\x6f\xac\x64\x28\x06\x18\ + \\x4e\x88\x7f\x99\x88\x4e\xdb\x65\x1f\x9c\xf2\x89\x50\x20\x38\x13\ + \\x4a\x0d\xcc\x28\x74\x4a\xc5\x6f\x65\x93\xea\x0f\xb4\x33\xc0\x1e\ + \\x3b\xa4\x09\x87\xf6\xa1\x6a\x59\x84\x0f\x22\x73\xf6\xc2\x99\x18\ + \\x96\xb6\x07\x6c\xf8\xe7\xee\xad\x36\xd9\xb4\xf5\x91\x35\xae\x13\ + \\x56\x57\x0c\xe0\xf3\x3f\x7e\x49\x24\xf5\xba\x22\x83\x22\x7d\x1f\ + \\x45\xac\xd6\x4c\xf6\xff\x64\xd4\xe9\x90\x95\xe8\x68\xe8\x30\x19\ + \\xd1\x89\x78\x3d\xf8\xff\x83\x43\xee\x73\x44\xed\x53\x20\x27\x14\ + \\x74\xa1\x93\x97\xc6\xcc\x9c\xcf\xf1\x8f\x03\xf1\x0f\x4d\x1f\x10\ + \\x52\x02\xb9\x25\xa4\x47\x61\x7f\x1c\xb3\x05\xe8\x7f\xae\xcb\x19\ + \\x0f\x35\xc7\xb7\xe9\xd2\x4d\xcc\x16\x5c\xd1\xec\xff\xf1\xa2\x14\ + \\xd9\x90\xd2\x5f\x21\x0f\x0b\x3d\x12\xb0\xda\x23\x33\x5b\x82\x10\ + \\xc1\xe7\x50\x99\x68\x4b\xab\x61\x50\xb3\x2a\x06\x85\x2b\x6a\x1a\ + \\x67\xb9\x40\x14\xba\xa2\x22\x4e\x40\x5c\x55\x6b\x6a\xbc\x21\x15\ + \\x53\x94\x00\xdd\x94\xe8\x4e\x0b\xcd\x49\x44\xbc\xee\xc9\xe7\x10\ + \\x51\xed\x00\xc8\x87\xda\x17\x12\x48\xa9\xd3\xc6\x4a\x76\x0c\x1b\ + \\xda\xbd\x00\xa0\x6c\x48\x46\xdb\x6c\x87\xdc\x6b\xd5\x91\xa3\x15\ + \\xaf\x64\xcd\x4c\xbd\x06\x05\x49\x8a\x9f\xe3\xef\xdd\xa7\x4f\x11\ + \\xb1\x3a\xe2\x7a\xc8\x0a\x08\xa8\x43\xff\x38\xe6\x2f\xa6\xb2\x1b\ + \\xf4\x2e\xe8\xfb\x39\xa2\x39\x53\x69\xff\x93\x1e\xf3\x84\x28\x16\ + \\x5d\xf2\xec\x2f\xfb\xb4\xc7\x75\x87\xff\x0f\xb2\xf5\x03\xba\x11\ + \\x2e\xea\x47\xe6\x91\x21\xd9\x22\x3f\xff\x7f\xb6\x22\xd3\x5c\x1c\ + \\xf2\x54\x06\x85\x41\x81\x7a\xb5\x65\xff\xff\x91\xe8\xa8\xb0\x16\ + \\xf5\x43\x38\x37\x01\x01\x62\xc4\xb7\x32\x33\xdb\x86\xed\x26\x12\ + \\xee\x9f\xf3\xf1\x01\x68\x36\x3a\x59\x84\xeb\x91\xa4\x15\x0b\x1d\ + \\x8b\x19\xf6\x27\x9b\xb9\x5e\xfb\xe0\x69\xbc\x74\x50\x11\x3c\x17\ + \\xd6\x7a\x5e\x86\xe2\xfa\x7e\x2f\xe7\x87\x63\x5d\x40\x74\x96\x12\ + \\x56\x91\xfd\xd6\xd0\xf7\x97\xe5\x71\xd9\x38\x62\xcd\x86\xbd\x1d\ + \\xab\xda\xca\x78\x0d\x93\x79\x84\xc1\x7a\x2d\xe8\x3d\xd2\xca\x17\ + \\x56\x15\x6f\x2d\x71\x42\x61\xd0\x9a\xc8\x8a\x86\x31\xa8\x08\x13\ + \\x22\x22\x18\xaf\x4e\x6a\x68\x4d\x91\xda\xaa\x3d\x4f\x40\x74\x1e\ + \\xe8\xb4\x79\xf2\x3e\x88\x53\xa4\xda\xae\x88\x64\x3f\x00\x5d\x18\ + \\x87\x5d\x61\x28\xff\x6c\xdc\xe9\xae\x58\x6d\x50\xcc\x99\x7d\x13\ + \\xa4\x95\x68\x0d\x65\xae\x60\xa9\xe4\x8d\x48\x1a\x7a\x5c\x2f\x1f\ + \\x83\x44\xed\x3d\xb7\xbe\xb3\xba\x83\x71\xa0\xae\x61\xb0\xf2\x18\ + \\x36\x9d\x8a\x31\x2c\x32\xf6\x2e\x36\xc1\xe6\xbe\xe7\x59\xf5\x13"# + +-- | Table of 5^(-e2-q) / 2^k + 1 +-- Byte-swapped version of +-- > fmap (fnorm double_pow5_bitcount) [0..double_max_split] +double_pow5_split :: Addr +double_pow5_split = Addr + "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x1f\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x13\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x18\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x84\x1e\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x12\x13\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\xd7\x17\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\xcd\x1d\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x5f\xa0\x12\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x76\x48\x17\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x94\x1a\x1d\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xe5\x9c\x30\x12\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x1e\xc4\xbc\x16\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x26\xf5\x6b\x1c\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x37\x79\xc3\x11\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\xd8\x85\x57\x34\x16\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x4e\x67\x6d\xc1\x1b\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x91\x60\xe4\x58\x11\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x8c\xb5\x78\x1d\xaf\x15\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\xef\xe2\xd6\xe4\x1a\x1b\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\xd5\x4d\x06\xcf\xf0\x10\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x80\xf6\x4a\xe1\xc7\x02\x2d\x15\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x20\xb4\x9d\xd9\x79\x43\x78\x1a\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x94\x90\x02\x28\x2c\x2a\x8b\x10\ + \\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x34\x03\x32\xb7\xf4\xad\x14\ + \\x00\x00\x00\x00\x00\x00\x00\x40\xe7\x01\x84\xfe\xe4\x71\xd9\x19\ + \\x00\x00\x00\x00\x00\x00\x00\x88\x30\x81\x12\x1f\x2f\xe7\x27\x10\ + \\x00\x00\x00\x00\x00\x00\x00\xaa\x7c\x21\xd7\xe6\xfa\xe0\x31\x14\ + \\x00\x00\x00\x00\x00\x00\x80\xd4\xdb\xe9\x8c\xa0\x39\x59\x3e\x19\ + \\x00\x00\x00\x00\x00\x00\xa0\xc9\x52\x24\xb0\x08\x88\xef\x8d\x1f\ + \\x00\x00\x00\x00\x00\x00\x04\xbe\xb3\x16\x6e\x05\xb5\xb5\xb8\x13\ + \\x00\x00\x00\x00\x00\x00\x85\xad\x60\x9c\xc9\x46\x22\xe3\xa6\x18\ + \\x00\x00\x00\x00\x00\x40\xe6\xd8\x78\x03\x7c\xd8\xea\x9b\xd0\x1e\ + \\x00\x00\x00\x00\x00\xe8\x8f\x87\x2b\x82\x4d\xc7\x72\x61\x42\x13\ + \\x00\x00\x00\x00\x00\xe2\x73\x69\xb6\xe2\x20\x79\xcf\xf9\x12\x18\ + \\x00\x00\x00\x00\x80\xda\xd0\x03\x64\x1b\x69\x57\x43\xb8\x17\x1e\ + \\x00\x00\x00\x00\x90\x88\x62\x82\x1e\xb1\xa1\x16\x2a\xd3\xce\x12\ + \\x00\x00\x00\x00\xb4\x2a\xfb\x22\x66\x1d\x4a\x9c\xf4\x87\x82\x17\ + \\x00\x00\x00\x00\x61\xf5\xb9\xab\xbf\xa4\x5c\xc3\xf1\x29\x63\x1d\ + \\x00\x00\x00\xa0\x5c\x39\x54\xcb\xf7\xe6\x19\x1a\x37\xfa\x5d\x12\ + \\x00\x00\x00\xc8\xb3\x47\x29\xbe\xb5\x60\xa0\xe0\xc4\x78\xf5\x16\ + \\x00\x00\x00\xba\xa0\x99\xb3\x2d\xe3\x78\xc8\x18\xf6\xd6\xb2\x1c\ + \\x00\x00\x40\x74\x04\x40\x90\xfc\x8d\x4b\x7d\xcf\x59\xc6\xef\x11\ + \\x00\x00\x50\x91\x05\x50\xb4\x7b\x71\x9e\x5c\x43\xf0\xb7\x6b\x16\ + \\x00\x00\xa4\xf5\x06\x64\xa1\xda\x0d\xc6\x33\x54\xec\xa5\x06\x1c\ + \\x00\x80\x86\x59\x84\xde\xa4\xa8\xc8\x5b\xa0\xb4\xb3\x27\x84\x11\ + \\x00\x20\xe8\x6f\x25\x16\xce\xd2\xba\x72\xc8\xa1\xa0\x31\xe5\x15\ + \\x00\x28\xe2\xcb\xae\x9b\x81\x87\x69\x8f\x3a\xca\x08\x7e\x5e\x1b\ + \\x00\x59\x6d\x3f\x4d\x01\xb1\xf4\xa1\x99\x64\x7e\xc5\x0e\x1b\x11\ + \\x40\xaf\x48\x8f\xa0\x41\xdd\x71\x0a\xc0\xfd\xdd\x76\xd2\x61\x15\ + \\x10\xdb\x1a\xb3\x08\x92\x54\x0e\x0d\x30\x7d\x95\x14\x47\xba\x1a\ + \\xea\xc8\xf0\x6f\x45\xdb\xf4\x28\x08\x3e\x6e\xdd\x6c\x6c\xb4\x10\ + \\x24\xfb\xec\xcb\x16\x12\x32\x33\x8a\xcd\xc9\x14\x88\x87\xe1\x14\ + \\xed\x39\xe8\x7e\x9c\x96\xfe\xbf\xec\x40\xfc\x19\x6a\xe9\x19\x1a\ + \\x34\x24\x51\xcf\x21\x1e\xff\xf7\x93\xa8\x3d\x50\xe2\x31\x50\x10\ + \\x41\x6d\x25\x43\xaa\xe5\xfe\xf5\xb8\x12\x4d\xe4\x5a\x3e\x64\x14\ + \\x92\xc8\xee\xd3\x14\x9f\x7e\x33\x67\x57\x60\x9d\xf1\x4d\x7d\x19\ + \\xb6\x7a\xea\x08\xda\x46\x5e\x00\x41\x6d\xb8\x04\x6e\xa1\xdc\x1f\ + \\xb2\x8c\x92\x45\x48\xec\x3a\xa0\x48\x44\xf3\xc2\xe4\xe4\xe9\x13\ + \\xde\x2f\xf7\x56\x5a\xa7\x49\xc8\x5a\x15\xb0\xf3\x1d\x5e\xe4\x18\ + \\xd6\xfb\xb4\xec\x30\x11\x5c\x7a\xb1\x1a\x9c\x70\xa5\x75\x1d\x1f\ + \\x65\x1d\xf1\x93\xbe\x8a\x79\xec\xae\x90\x61\x66\x87\x69\x72\x13\ + \\xbf\x64\xed\x38\x6e\xed\x97\xa7\xda\xf4\xf9\x3f\xe9\x03\x4f\x18\ + \\xef\xbd\x28\xc7\xc9\xe8\x7d\x51\x11\x72\xf8\x8f\xe3\xc4\x62\x1e\ + \\xb5\x76\x79\x1c\x7e\xb1\xee\xd2\x4a\x47\xfb\x39\x0e\xbb\xfd\x12\ + \\x62\xd4\x97\xa3\xdd\x5d\xaa\x87\x1d\x19\x7a\xc8\xd1\x29\xbd\x17\ + \\x7b\xc9\x7d\x0c\x55\xf5\x94\xe9\x64\x9f\x98\x3a\x46\x74\xac\x1d\ + \\xed\x9d\xce\x27\x55\x19\xfd\x11\x9f\x63\x9f\xe4\xab\xc8\x8b\x12\ + \\x68\x45\xc2\x71\xaa\x5f\x7c\xd6\x86\x3c\xc7\xdd\xd6\xba\x2e\x17\ + \\xc2\xd6\x32\x0e\x95\x77\x1b\x8c\xa8\x0b\x39\x95\x8c\x69\xfa\x1c\ + \\x39\xc6\xdf\x28\xbd\x2a\x91\x57\x49\xa7\x43\xdd\xf7\x81\x1c\x12\ + \\xc8\xb7\x17\x73\x6c\x75\x75\xad\x1b\x91\x94\xd4\x75\xa2\xa3\x16\ + \\xba\xa5\xdd\x8f\xc7\xd2\xd2\x98\x62\xb5\xb9\x49\x13\x8b\x4c\x1c\ + \\x94\x87\xea\xb9\xbc\xc3\x83\x9f\x5d\x11\x14\x0e\xec\xd6\xaf\x11\ + \\x79\x29\x65\xe8\xab\xb4\x64\x07\xb5\x15\x99\x11\xa7\xcc\x1b\x16\ + \\xd7\x73\x7e\xe2\xd6\xe1\x3d\x49\x22\x5b\xff\xd5\xd0\xbf\xa2\x1b\ + \\x66\x08\x8f\x4d\x26\xad\xc6\x6d\xf5\x98\xbf\x85\xe2\xb7\x45\x11\ + \\x80\xca\xf2\xe0\x6f\x58\x38\xc9\x32\x7f\x2f\x27\xdb\x25\x97\x15\ + \\x20\x7d\x2f\xd9\x8b\x6e\x86\x7b\xff\x5e\xfb\xf0\x51\xef\xfc\x1a\ + \\x34\xae\xbd\x67\x17\x05\x34\xad\x5f\x1b\x9d\x36\x93\x15\xde\x10\ + \\xc1\x19\xad\x41\x5d\x06\x81\x98\x37\x62\x44\x04\xf8\x9a\x15\x15\ + \\x32\x60\x18\x92\xf4\x47\xa1\x7e\xc5\x7a\x55\x05\xb6\x01\x5b\x1a\ + \\x1f\x3c\x4f\xdb\xf8\xcc\x24\x6f\xbb\x6c\x55\xc3\x11\xe1\x78\x10\ + \\x27\x0b\x23\x12\x37\x00\xee\x4a\xea\xc7\x2a\x34\x56\x19\x97\x14\ + \\xf0\xcd\xab\xd6\x44\x80\xa9\xdd\xe4\x79\x35\xc1\xab\xdf\xbc\x19\ + \\xb6\x60\x2b\x06\x2b\xf0\x89\x0a\x2f\x6c\xc1\x58\xcb\x0b\x16\x10\ + \\xe4\x38\xb6\xc7\x35\x6c\x2c\xcd\x3a\xc7\xf1\x2e\xbe\x8e\x1b\x14\ + \\x1d\xc7\xa3\x39\x43\x87\x77\x80\x09\x39\xae\xba\x6d\x72\x22\x19\ + \\xe4\xb8\x0c\x08\x14\x69\x95\xe0\x4b\xc7\x59\x29\x09\x0f\x6b\x1f\ + \\x8e\xf3\x07\x85\xac\x61\x5d\x6c\x8f\x1c\xd8\xb9\x65\xe9\xa2\x13\ + \\x72\xf0\x49\xa6\x17\xba\x74\x47\xb3\x23\x4e\x28\xbf\xa3\x8b\x18\ + \\x8f\x6c\xdc\x8f\x9d\xe8\x51\x19\xa0\xac\x61\xf2\xae\x8c\xae\x1e\ + \\xd9\xc3\xe9\x79\x62\x31\xd3\x0f\xe4\x0b\x7d\x57\xed\x17\x2d\x13\ + \\xcf\x34\x64\x18\xbb\xfd\xc7\x13\xdd\x4e\x5c\xad\xe8\x5d\xf8\x17\ + \\x03\x42\x7d\xde\x29\xfd\xb9\x58\x94\x62\xb3\xd8\x62\x75\xf6\x1d\ + \\x42\x49\x0e\x2b\x3a\x3e\x74\xb7\x9c\x1d\x70\xc7\x5d\x09\xba\x12\ + \\x92\xdb\xd1\xb5\xc8\x4d\x51\xe5\x03\x25\x4c\x39\xb5\x8b\x68\x17\ + \\x77\x52\x46\xe3\x3a\xa1\xa5\xde\x44\x2e\x9f\x87\xa2\xae\x42\x1d\ + \\x8a\xf3\x0b\xce\xc4\x84\x27\x0b\xeb\x7c\xc3\x94\x25\xad\x49\x12\ + \\x6d\xf0\x8e\x01\xf6\x65\xf1\xcd\x25\x5c\xf4\xf9\x6e\x18\xdc\x16\ + \\x88\xac\xf2\x81\x73\xbf\x6d\x41\x2f\x73\x71\xb8\x8a\x1e\x93\x1c\ + \\xd5\xab\x37\x31\xa8\x97\xe4\x88\xfd\xe7\x46\xb3\x16\xf3\xdb\x11\ + \\xca\x96\x85\x3d\x92\xbd\x1d\xeb\xfc\xa1\x18\x60\xdc\xef\x52\x16\ + \\x7d\xfc\xe6\xcc\xf6\x2c\xe5\x25\x7c\xca\x1e\x78\xd3\xab\xe7\x1b\ + \\xce\x5d\x10\x40\x1a\x3c\xaf\x97\x8d\x3e\x13\x2b\x64\xcb\x70\x11\ + \\x42\x75\x14\xd0\x20\x0b\x9b\xfd\x30\x0e\xd8\x35\x3d\xfe\xcc\x15\ + \\x92\x92\x19\x04\xe9\xcd\x01\x3d\xbd\x11\x4e\x83\xcc\x3d\x40\x1b\ + \\x9b\xfb\x8f\xa2\xb1\x20\x21\x46\x16\xcb\x10\xd2\x9f\x26\x08\x11\ + \\x82\xfa\x33\x0b\xde\x68\xa9\xd7\xdb\xfd\x94\xc6\x47\x30\x4a\x15\ + \\x23\xf9\x00\x8e\x15\xc3\x93\xcd\x52\x3d\x3a\xb8\x59\xbc\x9c\x1a\ + \\xb6\x9b\xc0\x78\xed\x59\x7c\xc0\x53\x66\x24\x13\xb8\xf5\xa1\x10\ + \\xa3\xc2\xf0\xd6\x68\x70\x9b\xb0\xe8\x7f\xed\x17\x26\x73\xca\x14\ + \\x4c\xf3\xac\x0c\x83\x4c\xc2\xdc\xe2\xdf\xe8\x9d\xef\x0f\xfd\x19\ + \\x0f\x18\xec\xe7\xd1\x6f\xf9\xc9\xed\x8b\xb1\xc2\xf5\x29\x3e\x10\ + \\x13\x1e\xe7\x61\xc6\xcb\x77\x3c\xe9\xee\x5d\x33\x73\xb4\x4d\x14\ + \\x98\xe5\x60\xfa\xb7\xbe\x95\x8b\xa3\x6a\x35\x00\x90\x21\x61\x19\ + \\xfe\x1e\xf9\xf8\x65\x2e\x7b\x6e\x4c\xc5\x42\x00\xf4\x69\xb9\x1f\ + \\x5f\xb3\x9b\xbb\xff\xfc\x0c\xc5\x4f\xbb\x29\x80\x38\xe2\xd3\x13\ + \\x37\xa0\x82\xaa\x3f\x3c\x50\xb6\x23\x2a\x34\xa0\xc6\xda\xc8\x18\ + \\x44\x48\x23\x95\x4f\x4b\xe4\xa3\xac\x34\x41\x48\x78\x11\xfb\x1e\ + \\x2b\x0d\x36\xbd\x11\xaf\x6e\xe6\xeb\xc0\x28\x2d\xeb\xea\x5c\x13\ + \\x75\x90\x83\x2c\xd6\x5a\x0a\xe0\x26\xf1\x72\xf8\xa5\x25\x34\x18\ + \\x93\x74\xa4\xb7\x8b\xf1\x0c\x98\x70\xad\x8f\x76\x0f\x2f\x41\x1e\ + \\xdc\xc8\xc6\x52\xf7\x16\x08\x5f\x66\xcc\x19\xaa\x69\xbd\xe8\x12\ + \\x13\x7b\x78\x27\xb5\x1c\xca\xf6\x7f\x3f\xa0\x14\xc4\xec\xa2\x17\ + \\xd7\x99\x56\x71\xe2\xa3\x7c\xf4\x5f\x4f\xc8\x19\xf5\xa7\x8b\x1d\ + \\x26\x20\xd6\x86\x6d\xe6\xcd\xf8\x9b\x31\x1d\x30\xf9\x48\x77\x12\ + \\x30\xa8\x8b\xe8\x08\x60\x01\xf7\x02\x7e\x24\x7c\x37\x1b\x15\x17\ + \\x3c\x92\xae\x22\x0b\xb8\xc1\xb4\x83\x9d\x2d\x5b\x05\x62\xda\x1c\ + \\x65\x1b\xad\xf5\x06\x13\xf9\x50\x72\x82\xfc\x58\x43\x7d\x08\x12\ + \\x3f\x62\x18\xb3\xc8\x57\x37\xe5\x0e\xa3\x3b\x2f\x94\x9c\x8a\x16\ + \\xcf\x7a\xde\xdf\xba\x2d\x85\x9e\xd2\x8b\x0a\x3b\xb9\x43\x2d\x1c\ + \\xc1\x0c\xeb\xcb\x94\x3c\x13\xa3\x63\x97\xe6\xc4\x53\x4a\x9c\x11\ + \\xf1\xcf\xe5\xfe\xb9\x0b\xd8\x8b\x3c\x3d\x20\xb6\xe8\x5c\x03\x16\ + \\xee\x43\x9f\x7e\xa8\x0e\xce\xae\x8b\x4c\xa8\xe3\x22\x34\x84\x1b\ + \\x75\x8a\x23\x4f\x29\xc9\x40\x4d\xd7\x2f\x49\xce\x95\xa0\x32\x11\ + \\x12\x6d\xec\xa2\x73\xfb\x90\x20\xcd\x7b\xdb\x41\xbb\x48\x7f\x15\ + \\x56\x88\xa7\x8b\x50\x3a\xb5\x68\xc0\x5a\x52\x12\xea\x1a\xdf\x1a\ + \\x36\xb5\x48\x57\x72\x44\x71\x41\xb8\x78\x73\x4b\xd2\x70\xcb\x10\ + \\x83\xe2\x1a\xed\x8e\x95\xcd\x51\xe6\x56\x50\xde\x06\x4d\xfe\x14\ + \\x24\x9b\x61\xa8\xf2\xfa\x40\xe6\x9f\x6c\xe4\x95\x48\xe0\x3d\x1a\ + \\xf7\x00\x3d\xa9\xd7\x9c\xe8\xef\xe3\xc3\xae\x5d\x2d\xac\x66\x10\ + \\x34\x41\x8c\x93\x0d\xc4\xe2\xeb\xdc\x74\x1a\xb5\x38\x57\x80\x14\ + \\x81\x51\x6f\xf8\x10\x75\xdb\x26\x14\x12\x61\xe2\x06\x6d\xa0\x19\ + \\xf1\x92\x45\x9b\x2a\x29\x49\x98\x4c\xab\x7c\x4d\x24\x44\x04\x10\ + \\xad\xf7\x16\x42\x75\x73\x5b\xbe\x1f\xd6\xdb\x60\x2d\x55\x05\x14\ + \\x98\xb5\x9c\x92\x52\x50\xf2\xad\xa7\xcb\x12\xb9\x78\xaa\x06\x19\ + \\xff\xe2\x43\x37\x67\xe4\x6e\x99\x91\x7e\x57\xe7\x16\x55\x48\x1f\ + \\xdf\x6d\x8a\x82\xc0\x4e\xe5\xff\x1a\xaf\x96\x50\x2e\x35\x8d\x13\ + \\x57\x09\x2d\xa3\x70\xa2\xde\xbf\xe1\x5a\xbc\xe4\x79\x82\x70\x18\ + \\xad\x4b\xf8\xcb\x0c\x4b\xd6\x2f\x9a\x71\xeb\x5d\x18\xa3\x8c\x1e\ + \\x4c\x2f\x7b\xff\xe7\xee\xe5\x5d\x00\x27\xb3\x3a\xef\xe5\x17\x13\ + \\x1f\xfb\x59\xff\xa1\x6a\x5f\x75\xc0\xf0\x5f\x09\x6b\xdf\xdd\x17\ + \\xe7\x79\x30\x7f\x4a\x45\xb7\x92\xf0\xec\xb7\xcb\x45\x57\xd5\x1d\ + \\x30\x4c\x7e\x8f\x4e\x8b\xb2\x5b\x16\xf4\x52\x9f\x8b\x56\xa5\x12\ + \\x3c\xdf\x5d\x33\x22\x2e\x9f\xf2\x1b\xb1\x27\x87\x2e\xac\x4e\x17\ + \\x0b\x57\x35\xc0\xaa\xf9\x46\xef\x62\x9d\xf1\x28\x3a\x57\x22\x1d\ + \\x67\x56\x21\xb8\x0a\x5c\x8c\xd5\x5d\x02\x97\x59\x84\x76\x35\x12\ + \\x01\xac\x29\x66\x0d\x73\xef\x4a\xf5\xc2\xfc\x6f\x25\xd4\xc2\x16\ + \\x01\x17\xb4\xbf\xd0\x4f\xab\x9d\xb2\xf3\xfb\xcb\x2e\x89\x73\x1c\ + \\x60\x8e\xd0\x77\xe2\x11\x8b\xa2\x4f\x78\x7d\x3f\xbd\x35\xc8\x11\ + \\xf9\xb1\xc4\x15\x5b\xd6\x2d\x8b\x63\xd6\x5c\x8f\x2c\x43\x3a\x16\ + \\x77\xde\x35\xdb\xf1\x4b\xf9\x6d\xfc\x0b\x34\xb3\xf7\xd3\xc8\x1b\ + \\x0a\xab\x01\x29\x77\xcf\xbb\xc4\x7d\x87\x00\xd0\x7a\x84\x5d\x11\ + \\xcd\x15\x42\xf3\x54\xc3\xea\x35\x5d\xa9\x00\x84\x99\xe5\xb4\x15\ + \\x40\x9b\x12\x30\x2a\x74\x65\x83\xb4\xd3\x00\xe5\xff\x1e\x22\x1b\ + \\x08\xa1\x0b\x5e\x9a\x68\x1f\xd2\x50\x84\x20\xef\x5f\x53\xf5\x10\ + \\x4a\x89\x8e\xf5\xc0\x42\xa7\x06\x65\xa5\xe8\xea\x37\xa8\x32\x15\ + \\x9d\x2b\xf2\x32\x71\x13\x51\x48\xbe\xce\xa2\xe5\x45\x52\x7f\x1a\ + \\x42\x5b\xd7\xbf\x26\xac\x32\xed\x36\xc1\x85\xaf\x6b\x93\x8f\x10\ + \\x12\x32\xcd\x6f\x30\x57\x7f\xa8\x84\x31\x67\x9b\x46\x78\xb3\x14\ + \\x97\x7e\xc0\x8b\xfc\x2c\x9f\xd2\xe5\xfd\x40\x42\x58\x56\xe0\x19\ + \\x1e\x4f\x58\xd7\x1d\x7c\xa3\xa3\xaf\x9e\x68\x29\xf7\x35\x2c\x10\ + \\xe6\x62\x2e\x4d\x25\x5b\x8c\x8c\x5b\xc6\xc2\xf3\x74\x43\x37\x14\ + \\x9f\xfb\x79\xa0\xee\x71\xaf\x6f\xf2\x77\xb3\x30\x52\x14\x45\x19\ + \\x87\x7a\x98\x48\x6a\x4e\x9b\x0b\xef\x55\xe0\xbc\x66\x59\x96\x1f\ + \\x94\x4c\x5f\x6d\x02\x11\x41\x67\xb5\x35\x0c\x36\xe0\xf7\xbd\x13\ + \\xba\x1f\xb7\x08\x43\x55\x11\xc1\x22\x43\x8f\x43\xd8\x75\xad\x18\ + \\xa8\xe7\xe4\xca\x93\xaa\x55\x71\xeb\x13\x73\x54\x4e\xd3\xd8\x1e\ + \\xc9\x10\xcf\x5e\x9c\x8a\xd5\x26\x73\xec\xc7\xf4\x10\x84\x47\x13\ + \\xfb\xd4\x82\x76\x43\xed\x8a\xf0\x8f\xe7\xf9\x31\x15\x65\x19\x18\ + \\x3a\x8a\x23\x54\x94\xa8\xad\xec\x73\x61\x78\x7e\x5a\xbe\x1f\x1e\ + \\x64\x36\x96\xb4\x5c\x89\xec\x73\xe8\x3c\x0b\x8f\xf8\xd6\xd3\x12\ + \\xfd\xc3\xbb\xe1\xb3\xab\xe7\x90\x22\x0c\xce\xb2\xb6\xcc\x88\x17\ + \\xfd\xb4\x2a\xda\xa0\x96\x21\x35\x2b\x8f\x81\x5f\xe4\xff\x6a\x1d\ + \\x1e\xb1\x5a\x88\x24\xfe\x34\x01\x7b\xf9\xb0\xbb\xee\xdf\x62\x12\ + \\x65\x5d\x71\xaa\xad\x3d\x82\xc1\xd9\x37\x9d\x6a\xea\x97\xfb\x16\ + \\xbf\xb4\x0d\x15\x19\xcd\xe2\x31\xd0\x85\x44\x05\xe5\x7d\xba\x1c\ + \\xf7\x90\x28\xad\x2f\xc0\x2d\x1f\xa2\xd3\x4a\x23\xaf\x8e\xf4\x11\ + \\x35\xb5\x72\x98\x3b\x30\xf9\xa6\x8a\x88\x1d\xec\x5a\xb2\x71\x16\ + \\x82\x62\x8f\x7e\x4a\x7c\xb7\x50\xad\xea\x24\xa7\xf1\x1e\x0e\x1c\ + \\x91\x9d\x19\x8f\xae\xad\x72\x52\xac\x12\x77\x08\x57\xd3\x88\x11\ + \\xf6\x04\xe0\x32\x1a\x59\x0f\x67\x57\xd7\x94\xca\x2c\x08\xeb\x15\ + \\x33\x06\x98\xbf\x60\x2f\xd3\x40\x2d\x0d\x3a\xfd\x37\xca\x65\x1b\ + \\xe0\x03\xbf\x77\x9c\xfd\x83\x48\x3c\x48\x44\xfe\x62\x9e\x1f\x11\ + \\xd8\xc4\xae\x95\x03\xfd\xa4\x5a\x4b\x5a\xd5\xbd\xfb\x85\x67\x15\ + \\x0e\x76\x1a\x7b\x44\x3c\x4e\x31\xde\xb0\x4a\xad\x7a\x67\xc1\x1a\ + \\xc9\x89\xf0\xcc\xaa\xe5\xd0\xde\x8a\xae\x4e\xac\xac\xe0\xb8\x10\ + \\x3b\xac\x2c\x80\x15\x1f\x85\x96\x2d\x5a\x62\xd7\xd7\x18\xe7\x14\ + \\x4a\xd7\x37\xe0\xda\x66\x26\xfc\xb8\xf0\x3a\xcd\x0d\xdf\x20\x1a\ + \\x8e\xe6\x22\xcc\x48\x00\x98\x9d\x73\xd6\x44\xa0\x68\x8b\x54\x10\ + \\x32\xa0\x2b\xff\x5a\x00\xfe\x84\x10\x0c\x56\xc8\x42\xae\x69\x14\ + \\x3e\x88\xf6\xbe\x71\x80\x3d\xa6\x14\x8f\x6b\x7a\xd3\x19\x84\x19\ + \\x4e\x2a\xb4\x2e\x8e\xe0\xcc\xcf\xd9\x72\x06\x59\x48\x20\xe5\x1f\ + \\x70\x9a\x30\xdd\x58\x0c\xe0\x21\xc8\x07\xa4\x37\x2d\x34\xef\x13\ + \\x0d\xc1\x7c\x14\x6f\x0f\x58\x2a\xba\x09\x8d\x85\x38\x01\xeb\x18\ + \\x50\xf1\x9b\xd9\x4a\x13\xee\xb4\x28\x4c\xf0\xa6\x86\xc1\x25\x1f\ + \\xd2\x76\x01\xc8\x0e\xcc\x14\x71\x99\x2f\x56\x28\xf4\x98\x77\x13\ + \\x86\xd4\x01\x7a\x12\xff\x59\xcd\x7f\xbb\x6b\x32\x31\x7f\x55\x18\ + \\xa8\x49\x82\x18\xd7\x7e\xb0\xc0\x5f\xaa\x06\x7f\xfd\xde\x6a\x1e\ + \\x09\x6e\x51\x6f\x46\x4f\x6e\xd8\x7b\x2a\x64\x6f\x5e\xcb\x02\x13\ + \\x8b\xc9\x25\x0b\x18\xe3\x89\xce\x1a\x35\x3d\x0b\x36\x7e\xc3\x17\ + \\xee\x3b\xef\x0d\xde\x5b\x2c\x82\x61\x82\x0c\x8e\xc3\x5d\xb4\x1d\ + \\x75\x85\xb5\xc8\x6a\xb9\x5b\xf1\x7c\xd1\xc7\x38\x9a\xba\x90\x12\ + \\xd2\xe6\xe2\x7a\xc5\xa7\xb2\x2d\xdc\xc5\xf9\xc6\x40\xe9\x34\x17\ + \\x86\xa0\x9b\xd9\xb6\x51\x1f\x39\x53\x37\xb8\xf8\x90\x23\x02\x1d\ + \\x54\x44\x01\x48\x12\x93\xb3\x03\x94\x22\x73\x9b\x3a\x56\x21\x12\ + \\x69\x95\x01\xda\xd6\x77\xa0\x04\x39\xeb\x4f\x42\xc9\xab\xa9\x16\ + \\xc3\xfa\x81\x90\xcc\x95\xc8\x45\x07\xe6\xe3\x92\xbb\x16\x54\x1c\ + \\xba\x3c\x51\xda\x9f\x5d\x9d\x8b\xc4\x6f\xce\x3b\x35\x8e\xb4\x11\ + \\xe8\x8b\xe5\xd0\x07\xb5\x84\xae\xb5\x0b\xc2\x8a\xc2\xb1\x21\x16\ + \\xe3\xee\x1e\xc5\x49\xe2\x25\x1a\xa3\x8e\x72\x2d\x33\x1e\xaa\x1b\ + \\x4d\x55\x33\x1b\x6e\xad\x57\xf0\x25\x99\x67\xfc\xdf\x52\x4a\x11\ + \\xa1\x2a\x00\xa2\xc9\x98\x6d\x6c\x6f\x7f\x81\xfb\x97\xe7\x9c\x15\ + \\x49\x35\x80\x0a\xfc\xfe\x88\x47\x4b\xdf\x61\xfa\x7d\x21\x04\x1b\ + \\x4e\x21\x90\x86\x5d\x9f\xb5\x0c\x8f\x2b\x7d\xbc\xee\x94\xe2\x10\ + \\xa1\x29\x34\xe8\x34\x07\xe3\xcf\x72\x76\x9c\x6b\x2a\x3a\x1b\x15\ + \\x0a\x34\x41\x22\x02\xc9\xdb\x83\x0f\x94\x83\x06\xb5\x08\x62\x1a\ + \\x86\xc0\x68\x55\xa1\x5d\x69\xb2\x89\x3c\x12\x24\x71\x45\x7d\x10\ + \\xa7\xf0\xc2\xaa\x09\xb5\x03\x1f\xac\xcb\x16\x6d\xcd\x96\x9c\x14\ + \\xd1\xac\x73\x15\x4c\xa2\xc4\x26\x97\x7e\x5c\xc8\x80\xbc\xc3\x19\ + \\x03\x4c\x68\x8d\x6f\xe5\x3a\x78\x1e\xcf\x39\x7d\xd0\x55\x1a\x10\ + \\x03\x5f\xc2\x70\xcb\x9e\x49\x16\xe6\x42\x88\x9c\x44\xeb\x20\x14\ + \\xc4\xf6\xf2\x4c\x7e\x06\xdc\x9b\x9f\x53\xaa\xc3\x15\x26\x29\x19\ + \\x76\xb4\x2f\xe0\x1d\x08\xd3\x82\x87\xe8\x94\x34\x9b\x6f\x73\x1f\ + \\xc9\xd0\x1d\xac\x12\xe5\xc3\xb1\x54\x11\xdd\x00\xc1\x25\xa8\x13\ + \\xfc\x44\x25\x57\x57\xde\x34\xde\xa9\x55\x14\x41\x31\x2f\x92\x18\ + \\x3b\x96\xee\x2c\xed\x15\xc2\x55\x14\x6b\x59\x91\xfd\xba\xb6\x1e\ + \\xe5\x1d\x15\x3c\xb4\x4d\x99\xb5\xec\xe2\xd7\x7a\xde\x34\x32\x13\ + \\x5e\x65\x1a\x4b\x21\xa1\xff\xe2\xa7\xdb\x8d\x19\x16\xc2\xfe\x17\ + \\xb6\xfe\xe0\x9d\x69\x89\xbf\xdb\x91\x52\xf1\x9f\x9b\x72\xfe\x1d\ + \\x31\x9f\xac\x02\xe2\xb5\x57\x29\x9b\xd3\xf6\x43\xa1\x07\xbf\x12\ + \\xfe\xc6\x57\x83\x5a\xa3\xad\xf3\x81\x88\xf4\x94\x89\xc9\x6e\x17\ + \\xbd\xb8\x2d\x24\x31\x0c\x99\x70\xa2\xaa\x31\xfa\xeb\x7b\x4a\x1d\ + \\x76\x93\x9c\xb6\x9e\xa7\x5f\x86\xa5\x0a\x5f\x7c\x73\x8d\x4e\x12\ + \\x54\xb8\x43\x64\x86\x91\xf7\xe7\x4e\xcd\x76\x5b\xd0\x30\xe2\x16\ + \\x69\xa6\x54\xfd\xe7\x75\xf5\xa1\xa2\x80\x54\x72\x04\xbd\x9a\x1c\ + \\x01\xe8\x54\xfe\xb0\x69\x39\xa5\x65\xd0\x74\xc7\x22\xb6\xe0\x11\ + \\x02\x22\xea\x3d\x1d\xc4\x87\x0e\x7f\x04\x52\x79\xab\xe3\x58\x16\ + \\x82\xaa\x64\x8d\x24\xb5\x29\xd2\x9e\x85\xa6\x57\x96\x1c\xef\x1b\ + \\x91\xea\x5e\xd8\x36\x11\x5a\x43\x83\x13\xc8\xf6\xdd\x71\x75\x11\ + \\x36\xa5\x76\x8e\x84\x95\x30\x14\x64\x18\x7a\x74\x55\xce\xd2\x15\ + \\x83\x4e\x14\xb2\xe5\xba\x3c\x19\x7d\x9e\x98\xd1\xea\x81\x47\x1b\ + \\x12\xb1\x4c\x8f\xcf\xf4\xc5\x2f\x0e\x63\xff\xc2\x32\xb1\x0c\x11\ + \\x56\xdd\x1f\x73\x03\x72\xb7\xbb\xd1\x3b\xbf\x73\x7f\xdd\x4f\x15\ + \\xac\xd4\xe7\x4f\x84\x4e\xa5\x2a\xc6\x0a\xaf\x50\xdf\xd4\xa3\x1a\ + \\xeb\xe4\xf0\xb1\x12\x51\xa7\xda\xbb\x66\x6d\x92\x0b\x65\xa6\x10\ + \\x26\x1e\x6d\x5e\x57\x25\x51\xd1\x6a\xc0\x08\x77\x4e\xfe\xcf\x14\ + \\xb0\x65\x08\x36\xad\x6e\xa5\x85\x85\xf0\xca\x14\xe2\xfd\x03\x1a\ + \\x8e\x3f\xc5\x41\x2c\x65\x87\x73\x53\xd6\xfe\x4c\xad\x7e\x42\x10\ + \\x71\x8f\x36\x52\x77\x3e\x69\x50\xe8\x8b\x3e\xa0\x58\x1e\x53\x14\ + \\x4e\x33\xc4\x26\x15\x8e\x83\x64\xe2\x2e\x4e\xc8\xee\xe5\x67\x19\ + \\x22\x40\x75\x70\x9a\x71\xa4\xfd\x9a\xba\x61\x7a\x6a\xdf\xc1\x1f\ + \\x15\x48\x49\x86\x00\xc7\x86\xde\xa0\x14\x7d\x8c\xa2\x2b\xd9\x13\ + \\x1a\x9a\xdb\xa7\xc0\x78\x28\x16\xc9\x59\x9c\x2f\x8b\x76\xcf\x18\ + \\xa1\x80\xd2\xd1\xf0\x96\xb2\x5b\x3b\x70\x83\xfb\x2d\x54\x03\x1f\ + \\x64\x90\x23\x83\x56\x9e\x4f\x19\x25\x26\x32\xbd\x9c\x14\x62\x13\ + \\x7e\x74\xec\x23\xec\x85\xa3\x5f\xae\xaf\x7e\xec\xc3\x99\x3a\x18\ + \\x9d\x91\xe7\x2c\x67\x67\x8c\xf7\x99\x5b\x9e\xe7\x34\x40\x49\x1e\ + \\x02\xbb\x10\x7c\xa0\xc0\xb7\x3a\x40\xf9\xc2\x10\x21\xc8\xed\x12\ + \\xc3\xe9\x14\x9b\xc8\xb0\x65\x49\x90\xb7\xf3\x54\x29\x3a\xa9\x17\ + \\x33\x24\xda\xc1\xfa\x1c\xbf\x5b\x74\xa5\x30\xaa\xb3\x88\x93\x1d\ + \\xa0\x56\x28\xb9\x1c\x72\x57\xb9\x68\x67\x5e\x4a\x70\x35\x7c\x12\ + \\x48\x6c\x72\xe7\xa3\x4e\xad\xe7\x42\x01\xf6\x5c\xcc\x42\x1b\x17\ + \\x5a\x07\x4f\xe1\x4c\xa2\x98\xa1\x93\x81\x33\x74\x7f\x13\xe2\x1c\ + \\x98\x64\xd1\x0c\x70\x65\xff\x44\xfc\x30\xa0\xa8\x2f\x4c\x0d\x12\ + \\xbe\xbd\x05\x10\xcc\x3e\x3f\x56\x3b\x3d\xc8\x92\x3b\x9f\x90\x16\ + \\x2e\x2d\x07\x14\x7f\x0e\xcf\x2b\x8a\x4c\x7a\x77\x0a\xc7\x34\x1c\ + \\x3d\x7c\x84\x6c\x0f\x69\x61\x5b\xd6\x6f\xac\x8a\x66\xfc\xa0\x11\ + \\x4c\x9b\xa5\x47\x53\xc3\x39\xf2\xcb\x8b\x57\x2d\x80\x3b\x09\x16\ + \\x1f\x02\x8f\x19\x28\x34\xc8\xee\xbe\x6e\xad\x38\x60\x8a\x8b\x1b\ + \\x53\x61\xf9\x0f\x99\x20\x3d\x55\x37\x65\x6c\x23\x7c\x36\x37\x11\ + \\xa8\xb9\xf7\x53\xbf\x68\x8c\x2a\x85\x7e\x47\x2c\x1b\x04\x85\x15\ + \\x12\xa8\xf5\x28\xef\x82\x2f\x75\x26\x5e\x59\xf7\x21\x45\xe6\x1a\ + \\x0b\x89\x99\x79\xd5\xb1\x3d\x09\xd8\xda\x97\x3a\x35\xeb\xcf\x10\ + \\x4e\xeb\xff\xd7\x4a\x1e\x8d\x0b\x8e\xd1\x3d\x89\x02\xe6\x03\x15\ + \\x22\xe6\xff\x8d\xdd\x65\x70\x8e\xf1\x45\x8d\x2b\x83\xdf\x44\x1a\ + \\xd5\xef\xbf\x78\xaa\x3f\x06\xf9\xb6\x4b\x38\xfb\xb1\x0b\x6b\x10\ + \\xca\xeb\xef\x16\x95\xcf\x47\xb7\xa4\x5e\x06\x7a\x9e\xce\x85\x14\ + \\xbd\xe6\xab\x5c\x7a\xc3\x19\xe5\x4d\xf6\x87\x18\x46\x42\xa7\x19\ + \\x36\x70\xeb\x79\x2c\x1a\x30\xaf\xf0\xf9\x54\xcf\x6b\x89\x08\x10\ + \\x43\x4c\x66\x98\xb7\x20\xfc\xda\x6c\x38\x2a\xc3\xc6\xab\x0a\x14\ + \\x54\xdf\x7f\x7e\xe5\x28\xbb\x11\x88\xc6\xf4\x73\xb8\x56\x0d\x19\ + \\x2a\xd7\x1f\xde\x1e\xf3\x29\x16\x2a\xf8\xf1\x90\x66\xac\x50\x1f\ + \\x7a\xe6\xd3\x4a\xf3\x37\xda\x4d\x1a\x3b\x97\x1a\xc0\x6b\x92\x13\ + \\x19\xe0\x88\x1d\xf0\xc5\x50\xe1\xe0\x09\x3d\x21\xb0\x06\x77\x18\ + \\x1f\x18\xeb\x24\x6c\xf7\xa4\x19\x59\x4c\x8c\x29\x5c\xc8\x94\x1e\ + \\x13\xef\x12\x97\xa3\x1a\x07\xb0\xb7\xaf\xf7\x99\x39\xfd\x1c\x13\ + \\xd8\xaa\xd7\x7c\x4c\xe1\x08\x9c\xa5\x9b\x75\x00\x88\x3c\xe4\x17\ + \\x8e\x95\x0d\x9c\x9f\x19\x0b\x03\x8f\x02\x93\x00\xaa\x4b\xdd\x1d\ + \\x79\x7d\x88\xc1\x03\xf0\xe6\x61\x99\xe1\x5b\x40\x4a\x4f\xaa\x12\ + \\xd7\x9c\xea\xb1\x04\xac\x60\xba\xff\xd9\x72\xd0\x1c\xe3\x54\x17\ + \\x0d\x44\x65\xde\x05\xd7\xf8\xa8\x7f\x90\x8f\x04\xe4\x1b\x2a\x1d\ + \\x88\x4a\xff\xaa\x63\x86\x9b\xc9\x4f\xba\xd9\x82\x6e\x51\x3a\x12\ + \\x2a\x1d\xbf\x95\xfc\x67\x02\xbc\xe3\x28\x90\x23\xca\xe5\xc8\x16\ + \\x74\xe4\x2e\xbb\xfb\x01\x03\xab\x1c\x33\x74\xac\x3c\x1f\x7b\x1c\ + \\xc9\x4e\xfd\x54\x3d\xe1\xe1\xea\xf1\x9f\xc8\xeb\x85\xf3\xcc\x11\ + \\x7b\xa2\x3c\xaa\x8c\x59\x9a\x65\xee\xc7\xba\x66\x67\x30\x40\x16\ + \\x1a\xcb\xcb\xd4\xef\xef\x00\xff\xe9\x79\x69\x40\x81\x3c\xd0\x1b\ + \\xf0\x5e\xff\xe4\xf5\x95\x60\x3f\x32\xec\x41\xc8\xd0\x25\x62\x11\ + \\xac\x36\x3f\x5e\x73\xbb\x38\xcf\x3e\x67\x52\xfa\x44\xaf\xba\x15\ + \\x57\x04\xcf\x35\x50\xea\x06\x83\x0e\x01\xe7\x38\x16\x5b\x29\x1b\ + \\xb6\x62\xa1\x21\x72\x52\xe4\x11\xa9\x60\x90\xe3\xed\xd8\xf9\x10\ + \\x64\xbb\x09\xaa\x0e\x67\x5d\x56\xd3\x78\x74\x5c\x29\x4f\x38\x15\ + \\x3d\x2a\x8c\x54\xd2\xc0\xf4\x2b\x08\x97\x91\xb3\xf3\x62\x86\x1a\ + \\x66\x9a\xd7\x74\x83\xf8\x78\x1b\x65\xfe\x3a\x50\xd8\xfd\x93\x10\ + \\x00\x81\x0d\x52\xa4\x36\x57\x62\xfe\xbd\x49\x64\x4e\xfd\xb8\x14\ + \\x40\xe1\x90\x66\x4d\x04\xed\xfa\x7d\x2d\x5c\xfd\xa1\x3c\xe7\x19\ + \\xc8\x8c\x1a\x60\xb0\x22\xd4\xbc\x6e\x9c\x59\x3e\xe5\x85\x30\x10\ + \\xfa\x2f\x21\x78\x5c\x2b\x09\x6c\x8a\x03\xf0\x8d\x5e\xa7\x3c\x14\ + \\xf8\x7b\x29\x96\x33\x76\x0b\x07\x6d\x04\x6c\x31\x36\xd1\x4b\x19\ + \\xf6\xda\xb3\x7b\xc0\x53\xce\x48\x88\x05\xc7\xbd\x83\xc5\x9e\x1f\ + \\xda\x68\x50\x4d\x58\xf4\x80\x2d\x75\x63\x9c\x56\x72\x3b\xc3\x13\ + \\x10\x83\xa4\x60\x6e\x31\xe1\x78\x52\x7c\x43\xec\x4e\x0a\xb4\x18"# + +-- | 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) +get_double_pow5_inv_split = + let !(Addr arr) = double_pow5_inv_split + in getWord128At arr + +-- | Index into the 128-bit word lookup table double_pow5_split +get_double_pow5_split :: Int -> (Word64, Word64) +get_double_pow5_split = + let !(Addr arr) = double_pow5_split + in getWord128At arr + +-- | 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,258 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns, MagicHash #-} +-- | +-- 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(..)) + +-- See Data.ByteString.Builder.RealFloat.TableGenerator for a high-level +-- explanation of the ryu algorithm + +-- | Table of 2^k / 5^q + 1 +-- Byte-swapped version of +-- > fmap (finv float_pow5_inv_bitcount) [0..float_max_inv_split] +-- +-- Displayed here as 2 Word64 table values per line +float_pow5_inv_split :: Addr +float_pow5_inv_split = Addr + "\x01\x00\x00\x00\x00\x00\x00\x08\x67\x66\x66\x66\x66\x66\x66\x06\ + \\xb9\x1e\x85\xeb\x51\xb8\x1e\x05\xfa\x7e\x6a\xbc\x74\x93\x18\x04\ + \\x2a\xcb\x10\xc7\xba\xb8\x8d\x06\x22\x3c\xda\x38\x62\x2d\x3e\x05\ + \\x4e\x63\x7b\x2d\xe8\xbd\x31\x04\x16\xd2\x2b\xaf\xa6\xfc\xb5\x06\ + \\x78\x0e\x23\x8c\xb8\x63\x5e\x05\x2d\xa5\xb5\x09\xfa\x82\x4b\x04\ + \\xae\x6e\xef\x75\xf6\x37\xdf\x06\x58\x25\x59\x5e\xf8\x5f\x7f\x05\ + \\x47\x84\x7a\x4b\x60\xe6\x65\x04\x71\xa0\x5d\x12\x9a\x70\x09\x07\ + \\xc1\xe6\x4a\xa8\xe1\x26\xa1\x05\x67\x85\xd5\xb9\xe7\xeb\x80\x04\ + \\x0b\x6f\x22\xf6\xa5\xac\x34\x07\xa3\x25\xb5\x91\x51\xbd\xc3\x05\ + \\xe9\xea\x90\x74\x74\x97\x9c\x04\x0e\xab\xb4\xed\x53\xf2\x60\x07\ + \\xd8\x88\x90\x24\x43\x28\xe7\x05\xe0\xd3\xa6\x83\x02\xed\xb8\x04\ + \\x66\xb9\xd7\x05\x04\x48\x8e\x07\x52\x94\xac\x04\xd0\x6c\x0b\x06\ + \\xdb\xa9\x23\x6a\xa6\xf0\xd5\x04\x2b\x76\x9f\x76\x3d\xb4\xbc\x07\ + \\xef\xc4\xb2\x2b\x31\x90\x30\x06\xf3\x03\x8f\xbc\x8d\xa6\xf3\x04\ + \\x51\x06\x18\x94\xaf\x3d\xec\x07\xda\xd1\xac\xa9\xbf\x97\x56\x06\ + \\xe2\xa7\xf0\xba\xff\x12\x12\x05"# + +-- | Table of 5^(-e2-q) / 2^k + 1 +-- Byte-swapped version of +-- > fmap (fnorm float_pow5_bitcount) [0..float_max_split] +-- +-- Displayed here as 2 Word64 table values per line +float_pow5_split :: Addr +float_pow5_split = Addr + "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x14\ + \\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x40\x1f\ + \\x00\x00\x00\x00\x00\x00\x88\x13\x00\x00\x00\x00\x00\x00\x6a\x18\ + \\x00\x00\x00\x00\x00\x80\x84\x1e\x00\x00\x00\x00\x00\xd0\x12\x13\ + \\x00\x00\x00\x00\x00\x84\xd7\x17\x00\x00\x00\x00\x00\x65\xcd\x1d\ + \\x00\x00\x00\x00\x20\x5f\xa0\x12\x00\x00\x00\x00\xe8\x76\x48\x17\ + \\x00\x00\x00\x00\xa2\x94\x1a\x1d\x00\x00\x00\x40\xe5\x9c\x30\x12\ + \\x00\x00\x00\x90\x1e\xc4\xbc\x16\x00\x00\x00\x34\x26\xf5\x6b\x1c\ + \\x00\x00\x80\xe0\x37\x79\xc3\x11\x00\x00\xa0\xd8\x85\x57\x34\x16\ + \\x00\x00\xc8\x4e\x67\x6d\xc1\x1b\x00\x00\x3d\x91\x60\xe4\x58\x11\ + \\x00\x40\x8c\xb5\x78\x1d\xaf\x15\x00\x50\xef\xe2\xd6\xe4\x1a\x1b\ + \\x00\x92\xd5\x4d\x06\xcf\xf0\x10\x80\xf6\x4a\xe1\xc7\x02\x2d\x15\ + \\x20\xb4\x9d\xd9\x79\x43\x78\x1a\x94\x90\x02\x28\x2c\x2a\x8b\x10\ + \\xb9\x34\x03\x32\xb7\xf4\xad\x14\xe7\x01\x84\xfe\xe4\x71\xd9\x19\ + \\x30\x81\x12\x1f\x2f\xe7\x27\x10\x7c\x21\xd7\xe6\xfa\xe0\x31\x14\ + \\xdb\xe9\x8c\xa0\x39\x59\x3e\x19\x52\x24\xb0\x08\x88\xef\x8d\x1f\ + \\xb3\x16\x6e\x05\xb5\xb5\xb8\x13\x60\x9c\xc9\x46\x22\xe3\xa6\x18\ + \\x78\x03\x7c\xd8\xea\x9b\xd0\x1e\x2b\x82\x4d\xc7\x72\x61\x42\x13\ + \\xb6\xe2\x20\x79\xcf\xf9\x12\x18\x64\x1b\x69\x57\x43\xb8\x17\x1e\ + \\x1e\xb1\xa1\x16\x2a\xd3\xce\x12\x66\x1d\x4a\x9c\xf4\x87\x82\x17\ + \\xbf\xa4\x5c\xc3\xf1\x29\x63\x1d\xf7\xe6\x19\x1a\x37\xfa\x5d\x12\ + \\xb5\x60\xa0\xe0\xc4\x78\xf5\x16\xe3\x78\xc8\x18\xf6\xd6\xb2\x1c\ + \\x8d\x4b\x7d\xcf\x59\xc6\xef\x11\x71\x9e\x5c\x43\xf0\xb7\x6b\x16\ + \\x0d\xc6\x33\x54\xec\xa5\x06\x1c"# + +-- | 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 +get_float_pow5_inv_split = + let !(Addr arr) = float_pow5_inv_split + in getWord64At arr + +-- | Index into the 64-bit word lookup table float_pow5_split +get_float_pow5_split :: Int -> Word64 +get_float_pow5_split = + let !(Addr arr) = float_pow5_split + in getWord64At arr + +-- | 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,905 @@ +{-# LANGUAGE ScopedTypeVariables, ExplicitForAll #-} +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} +{-# 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 + , Addr(..) + , ByteArray(..) + , 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.Char (ord) +import GHC.Int (Int(..), Int32(..)) +import GHC.Prim +import GHC.Ptr (Ptr(..), plusPtr) +import GHC.ST (ST(..), runST) +import GHC.Types (isTrue#) +import GHC.Word (Word8, Word32(..), Word64(..)) +import qualified Foreign.Storable as S (poke) + +#include +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ < 903 +import GHC.IntWord64 +#endif + +#if __GLASGOW_HASKELL__ >= 804 +import GHC.Float (castFloatToWord32, castDoubleToWord64) +#else +import System.IO.Unsafe (unsafePerformIO) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (castPtr) +import Foreign.Storable (peek) + +-- | 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 +castFloatToWord32 x = unsafePerformIO (with x (peek . castPtr)) + +-- | Interpret a 'Double' as a 'Word64' as if through a bit-for-bit copy. +-- (fallback if not available through GHC.Float) +-- +-- e.g +-- +-- > showHex (castDoubleToWord64 1.0) [] = "3ff0000000000000" +{-# NOINLINE castDoubleToWord64 #-} +castDoubleToWord64 :: Double -> Word64 +castDoubleToWord64 x = unsafePerformIO (with x (peek . castPtr)) +#endif + +-- | 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 = +#if defined(WORDS_BIGENDIAN) + ((wordToWord64# lo) `uncheckedShiftL64#` 32#) `or64#` (wordToWord64# hi) +#else + ((wordToWord64# hi) `uncheckedShiftL64#` 32#) `or64#` (wordToWord64# lo) +#endif + +-- | Unpacks a Word64 into 2 32-bit words (hi, lo) +unpackWord64 :: Word64# -> (# Word#, Word# #) +unpackWord64 w = +#if defined(WORDS_BIGENDIAN) + (# word64ToWord# w + , word64ToWord# (w `uncheckedShiftRL64#` 32#) + #) +#else + (# word64ToWord# (w `uncheckedShiftRL64#` 32#) + , word64ToWord# w + #) +#endif + +-- | 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 + +data Addr = Addr Addr# + +-- | Index into the 64-bit word lookup table provided +{-# INLINE getWord64At #-} +getWord64At :: Addr# -> Int -> Word64 +getWord64At arr (I# i) = +#if defined(WORDS_BIGENDIAN) + W64# (byteSwap64# (indexWord64OffAddr# arr i)) +#else + W64# (indexWord64OffAddr# arr i) +#endif + +-- | Index into the 128-bit word lookup table provided +-- Return (# high-64-bits , low-64-bits #) +-- NB: really just swaps the bytes and doesn't reorder the words +{-# INLINE getWord128At #-} +getWord128At :: Addr# -> Int -> (Word64, Word64) +getWord128At arr (I# i) = +#if defined(WORDS_BIGENDIAN) + ( W64# (byteSwap64# (indexWord64OffAddr# arr (i *# 2# +# 1#))) + , W64# (byteSwap64# (indexWord64OffAddr# arr (i *# 2#))) + ) +#else + ( W64# (indexWord64OffAddr# arr (i *# 2# +# 1#)) + , W64# (indexWord64OffAddr# arr (i *# 2#)) + ) +#endif + + +data ByteArray = ByteArray ByteArray# + +-- | Packs 2 bytes [lsb, msb] into 16-bit word +packWord16 :: Word# -> Word# -> Word# +packWord16 l h = +#if defined(WORDS_BIGENDIAN) + (h `uncheckedShiftL#` 8#) `or#` l +#else + (l `uncheckedShiftL#` 8#) `or#` h +#endif + +-- | Unpacks a 16-bit word into 2 bytes [lsb, msb] +unpackWord16 :: Word# -> (# Word#, Word# #) +unpackWord16 w = +#if defined(WORDS_BIGENDIAN) + (# w `and#` 0xff##, w `uncheckedShiftRL#` 8# #) +#else + (# w `uncheckedShiftRL#` 8#, w `and#` 0xff## #) +#endif + + +-- | ByteArray of 2-digit pairs 00..99 for faster ascii rendering +digit_table :: ByteArray +digit_table = runST (ST $ \s1 -> + let !(# s2, marr #) = newByteArray# 200# s1 + go y r = \i s -> + let !(h, l) = fquotRem10 y + e' = packWord16 (toAscii (unsafeRaw l)) (toAscii (unsafeRaw h)) +#if __GLASGOW_HASKELL__ >= 902 + s' = writeWord16Array# marr i (wordToWord16# e') s +#else + s' = writeWord16Array# marr i e' s +#endif + in if isTrue# (i ==# 99#) then s' else r (i +# 1#) s' + !(# s3, bs #) = unsafeFreezeByteArray# marr (foldr go (\_ s -> s) [0..99] 0# s2) + in (# s3, ByteArray bs #)) + +-- | Unsafe index a ByteArray for the 16-bit word at the index +unsafeAt :: ByteArray -> Int# -> Word# +unsafeAt (ByteArray bs) i = +#if __GLASGOW_HASKELL__ >= 902 + word16ToWord# (indexWord16Array# bs i) +#else + indexWord16Array# bs i +#endif + +-- | Write a 16-bit word into the given address +copyWord16 :: Word# -> Addr# -> State# d -> State# d +copyWord16 w a s = +#if __GLASGOW_HASKELL__ >= 902 + writeWord16OffAddr# a 0# (wordToWord16# w) s +#else + writeWord16OffAddr# a 0# w s +#endif + +-- | 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# d -> (# Addr#, State# d #) #-} +{-# SPECIALIZE writeMantissa :: Addr# -> Int# -> Word64 -> State# d -> (# Addr#, State# d #) #-} +writeMantissa :: forall a d. (Mantissa a) => Addr# -> Int# -> a -> State# d -> (# Addr#, State# d #) +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# d -> (# Addr#, State# d #) +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 + return $ runST (ST $ \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,185 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} +-- | +-- 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 + ) where + +import GHC.Float (int2Double) + + +-- 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 F2S and D2S +-- +-- -- | 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 + +-- -- | Generates a compile-time lookup table for floats as Word64 +-- gen_table_f :: Int -> (Int -> Integer) -> Q Exp +-- gen_table_f n f = return $ ListE (fmap (LitE . IntegerL . f) [0..n]) +-- +-- -- | Generates a compile-time lookup table for doubles as Word128 +-- gen_table_d :: Int -> (Int -> Integer) -> Q Exp +-- gen_table_d n f = return $ ListE (fmap ff [0..n]) +-- where +-- ff :: Int -> Exp +-- ff c = let r = f c +-- hi = r `shiftR` 64 +-- lo = r .&. ((1 `shiftL` 64) - 1) +-- in AppE (AppE (ConE 'Word128) (LitE . IntegerL $ hi)) (LitE . IntegerL $ lo) + +-- 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,8 +1,7 @@ -{-# LANGUAGE CPP, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} {-# OPTIONS_HADDOCK prune #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif -- | -- Module : Data.ByteString.Char8 @@ -44,162 +43,162 @@ 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, + 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, + readInteger, -- * 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,28 +206,28 @@ -- 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 @@ -266,15 +265,9 @@ import Data.ByteString.Internal -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative ((<$>)) -#endif - 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 System.IO (Handle,stdout) @@ -543,21 +536,12 @@ {-# 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: @@ -720,7 +704,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 +714,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 diff --git a/Data/ByteString/Internal.hs b/Data/ByteString/Internal.hs --- a/Data/ByteString/Internal.hs +++ b/Data/ByteString/Internal.hs @@ -3,12 +3,9 @@ UnboxedTuples, DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE PatternSynonyms, ViewPatterns #-} -#endif -#if __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Unsafe #-} -#endif +{-# LANGUAGE TemplateHaskellQuotes #-} {-# OPTIONS_HADDOCK not-home #-} -- | @@ -33,11 +30,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,51 +43,52 @@ 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) + 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) + fromForeignPtr, + toForeignPtr, + fromForeignPtr0, + toForeignPtr0, -- * Utilities - nullForeignPtr, -- :: ForeignPtr Word8 - checkedAdd, -- :: String -> Int -> Int -> Int + nullForeignPtr, + checkedAdd, -- * 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, @@ -105,27 +103,15 @@ 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) +#else 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 Data.List.NonEmpty (NonEmpty ((:|))) import Control.DeepSeq (NFData(rnf)) @@ -141,21 +127,10 @@ 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_ @@ -172,7 +147,7 @@ import GHC.CString (cstringLength#) import GHC.ForeignPtr (ForeignPtrContents(FinalPtr)) #else -import GHC.Ptr (Ptr(..), castPtr) +import GHC.Ptr (Ptr(..)) #endif #if (__GLASGOW_HASKELL__ < 802) || (__GLASGOW_HASKELL__ >= 811) @@ -183,6 +158,9 @@ import GHC.ForeignPtr (unsafeWithForeignPtr) #endif +import qualified Language.Haskell.TH.Lib as TH +import qualified Language.Haskell.TH.Syntax as TH + #if !MIN_VERSION_base(4,15,0) unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b unsafeWithForeignPtr = withForeignPtr @@ -221,10 +199,14 @@ -- data ByteString = BS {-# UNPACK #-} !(ForeignPtr Word8) -- payload {-# UNPACK #-} !Int -- length + -- ^ @since 0.11.0.0 deriving (Typeable) +-- | Type synonym for the strict flavour of 'ByteString'. +-- +-- @since 0.11.2.0 +type StrictByteString = ByteString -#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 @@ -235,7 +217,7 @@ -- 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', +-- /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 @@ -244,7 +226,6 @@ #if __GLASGOW_HASKELL__ >= 802 {-# COMPLETE PS #-} #endif -#endif instance Eq ByteString where (==) = eq @@ -252,20 +233,14 @@ 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 + stimes = times 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 @@ -277,13 +252,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� @@ -297,6 +270,24 @@ gunfold _ _ = error "Data.ByteString.ByteString.gunfold" dataTypeOf _ = mkNoRepType "Data.ByteString.ByteString" +-- | @since 0.11.2.0 +instance TH.Lift ByteString where +#if MIN_VERSION_template_haskell(2,16,0) + 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) + liftTyped = TH.unsafeCodeCoerce . TH.lift +#elif MIN_VERSION_template_haskell(2,16,0) + liftTyped = TH.unsafeTExpCoerce . TH.lift +#endif + ------------------------------------------------------------------------ -- Internal indexing @@ -304,7 +295,7 @@ -- 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 + accursedUnutterablePerformIO $ unsafeWithForeignPtr x g where g ptr = go 0 where @@ -370,33 +361,62 @@ unsafePackAddress :: Addr# -> IO ByteString unsafePackAddress addr# = do #if __GLASGOW_HASKELL__ >= 811 - return (BS (ForeignPtr addr# FinalPtr) (I# (cstringLength# addr#))) + unsafePackLenAddress (I# (cstringLength# addr#)) addr# #else - p <- newForeignPtr_ (castPtr cstr) - l <- c_strlen cstr - return $ BS p (fromIntegral l) - where - cstr :: CString - cstr = Ptr addr# + 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 __GLASGOW_HASKELL__ >= 811 + 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 __GLASGOW_HASKELL__ >= 811 - BS (ForeignPtr addr# FinalPtr) (I# (cstringLength# addr#)) + unsafePackLenLiteral (I# (cstringLength# addr#)) addr# #else let len = accursedUnutterablePerformIO (c_strlen (Ptr addr#)) - in BS (accursedUnutterablePerformIO (newForeignPtr_ (Ptr addr#))) (fromIntegral len) + 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 __GLASGOW_HASKELL__ >= 811 + BS (ForeignPtr addr# FinalPtr) len +#else + BS (accursedUnutterablePerformIO (newForeignPtr_ (Ptr addr#))) len +#endif +{-# INLINE unsafePackLenLiteral #-} + packUptoLenBytes :: Int -> [Word8] -> (ByteString, [Word8]) packUptoLenBytes len xs0 = unsafeCreateUptoN' len $ \p0 -> @@ -490,7 +510,7 @@ -- | /O(1)/ Build a ByteString from a ForeignPtr. -- --- If you do not need the offset parameter then you do should be using +-- If you do not need the offset parameter then you should be using -- 'Data.ByteString.Unsafe.unsafePackCStringLen' or -- 'Data.ByteString.Unsafe.unsafePackCStringFinalizer' instead. -- @@ -501,6 +521,7 @@ fromForeignPtr fp o = BS (plusForeignPtr fp o) {-# INLINE fromForeignPtr #-} +-- | @since 0.11.0.0 fromForeignPtr0 :: ForeignPtr Word8 -> Int -- ^ Length -> ByteString @@ -513,6 +534,8 @@ {-# 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 #-} @@ -538,30 +561,33 @@ -- | Create ByteString of size @l@ and use action @f@ to fill its contents. create :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString -create l f = do +create l action = do fp <- mallocByteString l - withForeignPtr fp $ \p -> f p + -- Cannot use unsafeWithForeignPtr, because action can diverge + withForeignPtr fp $ \p -> action 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'` l f@ returns the filled 'ByteString'. createUptoN :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString -createUptoN l f = do +createUptoN l action = do fp <- mallocByteString l - l' <- withForeignPtr fp $ \p -> f p + -- Cannot use unsafeWithForeignPtr, because action can diverge + l' <- withForeignPtr fp $ \p -> action p assert (l' <= l) $ return $! BS fp l' {-# INLINE createUptoN #-} --- | Like 'createUpToN', but also returns an additional value created by the +-- | 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 +createUptoN' l action = do fp <- mallocByteString l - (l', res) <- withForeignPtr fp $ \p -> f p + -- Cannot use unsafeWithForeignPtr, because action can diverge + (l', res) <- withForeignPtr fp $ \p -> action p assert (l' <= l) $ return (BS fp l', res) {-# INLINE createUptoN' #-} @@ -574,25 +600,28 @@ -- ByteString functions, using Haskell or C functions to fill the space. -- createAndTrim :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString -createAndTrim l f = do +createAndTrim l action = do fp <- mallocByteString l + -- Cannot use unsafeWithForeignPtr, because action can diverge withForeignPtr fp $ \p -> do - l' <- f p + l' <- action 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 +createAndTrim' l action = do fp <- mallocByteString l + -- Cannot use unsafeWithForeignPtr, because action can diverge withForeignPtr fp $ \p -> do - (off, l', res) <- f p + (off, l', res) <- action 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) +{-# INLINE createAndTrim' #-} -- | Wrapper of 'Foreign.ForeignPtr.mallocForeignPtrBytes' with faster implementation for GHC -- @@ -682,7 +711,6 @@ 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) @@ -707,7 +735,6 @@ 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 diff --git a/Data/ByteString/Lazy.hs b/Data/ByteString/Lazy.hs --- a/Data/ByteString/Lazy.hs +++ b/Data/ByteString/Lazy.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE CPP, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} {-# OPTIONS_HADDOCK prune #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif -- | -- Module : Data.ByteString.Lazy @@ -51,165 +49,174 @@ 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, + 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 @@ -220,20 +227,19 @@ ,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.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.Unsafe as S +import qualified Data.ByteString.Lazy.Internal.Deque as D import Data.ByteString.Lazy.Internal -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative ((<$>)) -import Data.Monoid (Monoid(..)) -#endif 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) @@ -266,7 +272,7 @@ -- | /O(c)/ Convert a list of strict 'ByteString' into a lazy 'ByteString' fromChunks :: [P.ByteString] -> ByteString -fromChunks = L.foldr chunk Empty +fromChunks = List.foldr chunk Empty -- | /O(c)/ Convert a lazy 'ByteString' into a list of strict 'ByteString' toChunks :: ByteString -> [P.ByteString] @@ -336,7 +342,7 @@ {-# INLINE snoc #-} -- | /O(1)/ Extract the first element of a ByteString, which must be non-empty. -head :: ByteString -> Word8 +head :: HasCallStack => ByteString -> Word8 head Empty = errorEmptyList "head" head (Chunk c _) = S.unsafeHead c {-# INLINE head #-} @@ -352,7 +358,7 @@ -- | /O(1)/ Extract the elements after the head of a ByteString, which must be -- non-empty. -tail :: ByteString -> ByteString +tail :: HasCallStack => ByteString -> ByteString tail Empty = errorEmptyList "tail" tail (Chunk c cs) | S.length c == 1 = cs @@ -361,7 +367,7 @@ -- | /O(n\/c)/ Extract the last element of a ByteString, which must be finite -- and non-empty. -last :: ByteString -> Word8 +last :: HasCallStack => ByteString -> Word8 last Empty = errorEmptyList "last" last (Chunk c0 cs0) = go c0 cs0 where go c Empty = S.unsafeLast c @@ -369,7 +375,7 @@ -- XXX Don't inline this. Something breaks with 6.8.2 (haven't investigated yet) -- | /O(n\/c)/ Return all the elements of a 'ByteString' except the last one. -init :: ByteString -> ByteString +init :: HasCallStack => ByteString -> ByteString init Empty = errorEmptyList "init" init (Chunk c0 cs0) = go c0 cs0 where go c Empty | S.length c == 1 = Empty @@ -427,8 +433,8 @@ -- | 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 +463,44 @@ 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'' 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) -- | '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 +528,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 +619,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 +637,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 +716,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,6 +750,28 @@ 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 _ | i <= 0 = Empty +takeEnd i cs0 = takeEnd' i cs0 + where takeEnd' 0 _ = Empty + takeEnd' n cs = + snd $ foldrChunks takeTuple (n,Empty) cs + takeTuple _ (0, cs) = (0, cs) + takeTuple c (n, cs) + | n > fromIntegral (S.length c) = (n - fromIntegral (S.length c), Chunk c cs) + | otherwise = (0, Chunk (S.takeEnd (fromIntegral n) c) cs) + -- | /O(n\/c)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ -- elements, or @[]@ if @n > 'length' xs@. drop :: Int64 -> ByteString -> ByteString @@ -701,6 +784,57 @@ 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 +dropEnd i p = go D.empty p + where go :: D.Deque -> ByteString -> ByteString + go deque (Chunk c cs) + | D.byteLength deque < i = go (D.snoc c deque) cs + | otherwise = + let (output, deque') = getOutput empty (D.snoc c deque) + in foldrChunks Chunk (go deque' cs) output + go deque Empty = fromDeque $ dropEndBytes deque i + + len c = fromIntegral (S.length c) + + -- get a `ByteString` from all the front chunks of the accumulating deque + -- for which we know they won't be dropped + getOutput :: ByteString -> D.Deque -> (ByteString, D.Deque) + getOutput out deque = case D.popFront deque of + Nothing -> (reverseChunks out, deque) + Just (x, deque') | D.byteLength deque' >= i -> + getOutput (Chunk x out) deque' + _ -> (reverseChunks out, deque) + + -- reverse a `ByteString`s chunks, keeping all internal `S.ByteString`s + -- unchanged + reverseChunks = foldlChunks (flip Chunk) empty + + -- drop n elements from the rear of the accumulating `deque` + dropEndBytes :: D.Deque -> Int64 -> D.Deque + dropEndBytes deque n = case D.popRear deque of + Nothing -> deque + Just (deque', x) | len x <= n -> dropEndBytes deque' (n - len x) + | otherwise -> + D.snoc (S.dropEnd (fromIntegral n) x) deque' + + -- build a lazy ByteString from an accumulating `deque` + fromDeque :: D.Deque -> ByteString + fromDeque deque = + List.foldr chunk Empty (D.front deque) `append` + List.foldl' (flip chunk) Empty (D.rear deque) + -- | /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) @@ -727,6 +861,27 @@ n | n < S.length c -> Chunk (S.take n c) Empty | otherwise -> Chunk c (takeWhile' cs) +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate. +-- +-- @'takeWhileEnd' p@ is equivalent to @'reverse' . 'takeWhile' p . 'reverse'@. +-- +-- >>> {-# LANGUAGE OverloadedLists #-) +-- >>> takeWhileEnd even [1,2,3,4,6] +-- [4,6] +-- +-- @since 0.11.2.0 +takeWhileEnd :: (Word8 -> Bool) -> ByteString -> ByteString +takeWhileEnd f = takeWhileEnd' + where takeWhileEnd' Empty = Empty + takeWhileEnd' cs = + snd $ foldrChunks takeTuple (True,Empty) cs + takeTuple _ (False, bs) = (False,bs) + takeTuple c (True,bs) = + case S.takeWhileEnd f c of + c' | S.length c' == S.length c -> (True, Chunk c bs) + | otherwise -> (False, fromStrict c' `append` bs) + -- | Similar to 'P.dropWhile', -- drops the longest (possibly empty) prefix of elements -- satisfying the predicate and returns the remainder. @@ -738,6 +893,29 @@ n | n < S.length c -> Chunk (S.drop n c) cs | otherwise -> dropWhile' cs +-- | 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'@. +-- +-- >>> {-# 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 'P.break', -- returns the longest (possibly empty) prefix of elements which __do not__ -- satisfy the predicate and the remainder of the string. @@ -755,7 +933,29 @@ | 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 @('takeWhileEnd' (not . p) &&& 'dropWhileEnd' (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 @@ -804,6 +1004,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 @('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) +-- +-- @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 @@ -898,13 +1117,13 @@ -- '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 +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 +1187,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 +1244,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 #-} @@ -1192,7 +1411,7 @@ -- | /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 #-} -- --------------------------------------------------------------------- @@ -1202,8 +1421,8 @@ 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) + inits' (Chunk c cs) = List.map (`Chunk` Empty) (List.tail (S.inits c)) + ++ List.map (Chunk c) (inits' cs) -- | /O(n)/ Return all final segments of the given 'ByteString', longest first. tails :: ByteString -> [ByteString] @@ -1395,22 +1614,22 @@ -- 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 -- $IOChunk -- 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,8 +1,6 @@ -{-# LANGUAGE CPP, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK prune #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif -- | -- Module : Data.ByteString.Lazy.Char8 @@ -33,142 +31,150 @@ 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, + 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 readInt, @@ -180,24 +186,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,7 +211,7 @@ import Data.ByteString.Lazy (fromChunks, toChunks ,empty,null,length,tail,init,append,reverse,transpose,cycle - ,concat,take,drop,splitAt,intercalate + ,concat,take,takeEnd,drop,dropEnd,splitAt,intercalate ,isPrefixOf,isSuffixOf,group,inits,tails,copy ,stripPrefix,stripSuffix ,hGetContents, hGet, hPut, getContents @@ -222,17 +228,13 @@ import Data.ByteString.Internal (w2c, c2w, isSpaceWord8) -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative ((<$>)) -#endif - 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 + ,unwords,words,maximum,minimum,all,concatMap,scanl,scanl1,scanr,scanr1,foldl1,foldr1 ,readFile,writeFile,appendFile,replicate,getContents,getLine,putStr,putStrLn ,zip,zipWith,unzip,notElem,repeat,iterate,interact,cycle) @@ -341,6 +343,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 +365,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 +402,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 +412,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,21 +508,67 @@ 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 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,10 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE TypeFamilies #-} -#if __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Unsafe #-} -#endif {-# OPTIONS_HADDOCK not-home #-} -- | @@ -25,7 +24,8 @@ module Data.ByteString.Lazy.Internal ( -- * The lazy @ByteString@ type and representation - ByteString(..), -- instances: Eq, Ord, Show, Read, Data, Typeable + ByteString(..), + LazyByteString, chunk, foldrChunks, foldlChunks, @@ -52,20 +52,15 @@ import qualified Data.ByteString.Internal 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) +#else 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 Data.List.NonEmpty (NonEmpty ((:|))) import Control.DeepSeq (NFData, rnf) import Data.String (IsString(..)) @@ -73,10 +68,10 @@ import Data.Typeable (Typeable) import Data.Data (Data(..), mkNoRepType) -#if MIN_VERSION_base(4,7,0) import GHC.Exts (IsList(..)) -#endif +import qualified Language.Haskell.TH.Syntax as TH + -- | A space-efficient representation of a 'Word8' vector, supporting many -- efficient operations. -- @@ -85,29 +80,28 @@ -- 8-bit characters. -- data ByteString = Empty | Chunk {-# UNPACK #-} !S.ByteString ByteString - deriving (Typeable) + deriving (Typeable, TH.Lift) -- See 'invariant' function later in this module for internal invariants. +-- | 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 +114,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� @@ -143,7 +135,6 @@ -- Packing and unpacking from lists packBytes :: [Word8] -> ByteString -packBytes [] = Empty packBytes cs0 = packChunks 32 cs0 where @@ -152,7 +143,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 @@ -275,7 +265,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,7 +276,6 @@ where go Empty = times (n-1) lbs0 go (Chunk c cs) = Chunk c (go cs) -#endif ------------------------------------------------------------------------ -- Conversions @@ -331,7 +319,7 @@ 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.unsafeWithForeignPtr fp $ \p -> do S.memcpy ptr p len goCopy cs (ptr `plusPtr` len) -- See the comment on Data.ByteString.Internal.concat for some background on diff --git a/Data/ByteString/Lazy/Internal/Deque.hs b/Data/ByteString/Lazy/Internal/Deque.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Internal/Deque.hs @@ -0,0 +1,65 @@ +{- | + A Deque used for accumulating `S.ByteString`s in `Data.ByteString.Lazy.dropEnd`. +-} +module Data.ByteString.Lazy.Internal.Deque ( + Deque (..), + empty, + null, + cons, + snoc, + popFront, + popRear, +) where + +import qualified Data.ByteString as S +import Data.Int (Int64) +import Prelude hiding (head, length, null) + +-- A `S.ByteString` Deque used as an accumulator for lazy +-- Bytestring operations +data Deque = Deque + { front :: [S.ByteString] + , rear :: [S.ByteString] + , -- | Total length in bytes + byteLength :: !Int64 + } + +-- An empty Deque +empty :: Deque +empty = Deque [] [] 0 + +-- Is the `Deque` empty? +-- O(1) +null :: Deque -> Bool +null deque = byteLength deque == 0 + +-- Add a `S.ByteString` to the front of the `Deque` +-- O(1) +cons :: S.ByteString -> Deque -> Deque +cons x (Deque fs rs acc) = Deque (x : fs) rs (acc + len x) + +-- Add a `S.ByteString` to the rear of the `Deque` +-- O(1) +snoc :: S.ByteString -> Deque -> Deque +snoc x (Deque fs rs acc) = Deque fs (x : rs) (acc + len x) + +len :: S.ByteString -> Int64 +len x = fromIntegral $ S.length x + +-- Pop a `S.ByteString` from the front of the `Deque` +-- Returns the bytestring and the updated Deque, or Nothing if the Deque is empty +-- O(1) , occasionally O(n) +popFront :: Deque -> Maybe (S.ByteString, Deque) +popFront (Deque [] rs acc) = case reverse rs of + [] -> Nothing + x : xs -> Just (x, Deque xs [] (acc - len x)) +popFront (Deque (x : xs) rs acc) = Just (x, Deque xs rs (acc - len x)) + +-- Pop a `S.ByteString` from the rear of the `Deque` +-- Returns the bytestring and the updated Deque, or Nothing if the Deque is empty +-- O(1) , occasionally O(n) +popRear :: Deque -> Maybe (Deque, S.ByteString) +popRear (Deque fs [] acc) = case reverse fs of + [] -> Nothing + x : xs -> Just (Deque [] xs (acc - len x), x) +popRear (Deque fs (x : xs) acc) = Just (Deque fs xs (acc - len x), x) diff --git a/Data/ByteString/Short.hs b/Data/ByteString/Short.hs --- a/Data/ByteString/Short.hs +++ b/Data/ByteString/Short.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif -- | -- Module : Data.ByteString.Short 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 @@ -3,9 +3,8 @@ UnliftedFFITypes #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#if __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Unsafe #-} -#endif +{-# LANGUAGE TemplateHaskellQuotes #-} {-# OPTIONS_HADDOCK not-home #-} -- | @@ -46,46 +45,31 @@ useAsCStringLen ) where -import Data.ByteString.Internal (ByteString(..), accursedUnutterablePerformIO, c_strlen) +import Data.ByteString.Internal (ByteString(..), accursedUnutterablePerformIO) +import qualified Data.ByteString.Internal as BS 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# @@ -95,12 +79,9 @@ , 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.Stack.Types (HasCallStack) import GHC.Word import Prelude ( Eq(..), Ord(..), Ordering(..), Read(..), Show(..) @@ -111,6 +92,9 @@ , return , Maybe(..) ) +import qualified Language.Haskell.TH.Lib as TH +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 @@ -127,6 +111,28 @@ data ShortByteString = SBS ByteArray# deriving Typeable +-- | @since 0.11.2.0 +instance TH.Lift ShortByteString where +#if MIN_VERSION_template_haskell(2,16,0) + lift sbs = [| unsafePackLenLiteral |] + `TH.appE` TH.litE (TH.integerL (fromIntegral len)) + `TH.appE` TH.litE (TH.BytesPrimL $ TH.Bytes ptr 0 (fromIntegral len)) + where + BS ptr len = fromShort sbs +#else + lift sbs = [| unsafePackLenLiteral |] + `TH.appE` TH.litE (TH.integerL (fromIntegral len)) + `TH.appE` TH.litE (TH.StringPrimL $ BS.unpackBytes bs) + where + bs@(BS _ len) = fromShort sbs +#endif + +#if MIN_VERSION_template_haskell(2,17,0) + liftTyped = TH.unsafeCodeCoerce . TH.lift +#elif MIN_VERSION_template_haskell(2,16,0) + liftTyped = TH.unsafeTExpCoerce . TH.lift +#endif + -- 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, @@ -139,18 +145,12 @@ 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 @@ -162,13 +162,11 @@ 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� @@ -197,7 +195,7 @@ null sbs = length sbs == 0 -- | /O(1)/ 'ShortByteString' index (subscript) operator, starting from 0. -index :: ShortByteString -> Int -> Word8 +index :: HasCallStack => ShortByteString -> Int -> Word8 index sbs i | i >= 0 && i < length sbs = unsafeIndex sbs i | otherwise = indexError sbs i @@ -225,11 +223,15 @@ unsafeIndex :: ShortByteString -> Int -> Word8 unsafeIndex sbs = indexWord8Array (asBA sbs) -indexError :: ShortByteString -> Int -> a +indexError :: HasCallStack => ShortByteString -> Int -> a indexError sbs i = error $ "Data.ByteString.Short.index: error in array index; " ++ show i ++ " not in range [0.." ++ show (length sbs) ++ ")" +-- | @since 0.11.2.0 +unsafePackLenLiteral :: Int -> Addr# -> ShortByteString +unsafePackLenLiteral len addr# = + accursedUnutterablePerformIO $ createFromPtr (Ptr addr#) len ------------------------------------------------------------------------ -- Internal utils @@ -281,23 +283,12 @@ 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 ------------------------------------------------------------------------ @@ -491,12 +482,10 @@ 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#) = @@ -558,78 +547,10 @@ -> 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 @@ -638,7 +559,7 @@ -- @since 0.10.10.0 packCString :: CString -> IO ShortByteString packCString cstr = do - len <- c_strlen cstr + len <- BS.c_strlen cstr packCStringLen (cstr, fromIntegral len) -- | /O(n)./ Construct a new @ShortByteString@ from a @CStringLen@. The @@ -681,7 +602,7 @@ -- --------------------------------------------------------------------- -- Internal utilities -moduleErrorIO :: String -> String -> IO a +moduleErrorIO :: HasCallStack => String -> String -> IO a moduleErrorIO fun msg = throwIO . userError $ moduleErrorMsg fun msg {-# NOINLINE moduleErrorIO #-} 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,5 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -#if __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Unsafe #-} -#endif -- | -- Module : Data.ByteString.Unsafe @@ -22,29 +19,29 @@ 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 @@ -76,7 +73,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 +95,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 +104,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 +262,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 +282,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/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/bench/BenchAll.hs b/bench/BenchAll.hs --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -39,6 +39,7 @@ import System.Random import BenchBoundsCheckFusion +import BenchCount import BenchCSV import BenchIndices @@ -214,22 +215,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 @@ -245,7 +239,6 @@ main :: IO () main = do - mapM_ putStrLn sanityCheckInfo defaultMain [ bgroup "Data.ByteString.Builder" [ bgroup "Small payload" @@ -411,20 +404,43 @@ , 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 +460,11 @@ , 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 ] , benchBoundsCheckFusion + , benchCount , benchCSV , benchIndices ] diff --git a/bench/BenchCSV.hs b/bench/BenchCSV.hs --- a/bench/BenchCSV.hs +++ b/bench/BenchCSV.hs @@ -122,9 +122,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 +133,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 +337,8 @@ -- Difference-list based rendering ------------------------------------------------------------------------------ +#ifdef MIN_VERSION_dlist + type DString = D.DList Char renderStringD :: String -> DString @@ -360,6 +365,8 @@ benchDListUtf8 = bench "utf8 + renderTableD maxiTable" $ nf (L.length . B.toLazyByteString . B.stringUtf8 . D.toList . renderTableD) maxiTable +#endif + ------------------------------------------------------------------------------ -- Text Builder ------------------------------------------------------------------------------ @@ -406,7 +413,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/bytestring.cabal b/bytestring.cabal --- a/bytestring.cabal +++ b/bytestring.cabal @@ -1,5 +1,5 @@ Name: bytestring -Version: 0.11.1.0 +Version: 0.11.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) @@ -54,9 +54,13 @@ 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.0.1, + GHC==8.10.4, + GHC==8.8.4, + GHC==8.6.5, + GHC==8.4.4, + GHC==8.2.2, + GHC==8.0.2 Build-Type: Simple Cabal-Version: >= 1.10 extra-source-files: README.md Changelog.md @@ -65,12 +69,8 @@ type: git location: https://github.com/haskell/bytestring -flag integer-simple - description: Use the simple integer library instead of GMP - default: False - library - build-depends: base >= 4.3 && < 5, ghc-prim, deepseq + build-depends: base >= 4.9 && < 5, ghc-prim, deepseq, template-haskell exposed-modules: Data.ByteString Data.ByteString.Char8 @@ -85,16 +85,21 @@ Data.ByteString.Builder Data.ByteString.Builder.Extra Data.ByteString.Builder.Prim + Data.ByteString.Builder.RealFloat -- perhaps only exposed temporarily Data.ByteString.Builder.Internal Data.ByteString.Builder.Prim.Internal - other-modules: - Data.ByteString.Builder.ASCII - Data.ByteString.Builder.Prim.Binary + other-modules: Data.ByteString.Builder.ASCII Data.ByteString.Builder.Prim.ASCII - Data.ByteString.Builder.Prim.Internal.Floating + 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.Lazy.Internal.Deque default-language: Haskell2010 other-extensions: CPP, @@ -107,92 +112,76 @@ 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 ghc-options: -Wall -fwarn-tabs -O2 -fmax-simplifier-iterations=10 -fdicts-cheap -fspec-constr-count=6 + + c-sources: cbits/fpstring.c + cbits/itoa.c + + if (arch(aarch64)) + c-sources: cbits/aarch64/is-valid-utf8.c + else + c-sources: cbits/is-valid-utf8.c + + cc-options: -std=c11 + + -- Required, due to the following issues: + -- * https://gitlab.haskell.org/ghc/ghc/-/issues/20525#note_385580 + -- * https://gitlab.haskell.org/ghc/ghc/-/issues/19417 + if os(windows) + extra-libraries: gcc_s gcc - c-sources: cbits/fpstring.c - cbits/itoa.c include-dirs: include includes: fpstring.h install-includes: fpstring.h - -- flags for the decimal integer serialization code - if impl(ghc >= 8.11) - build-depends: ghc-bignum >= 1.0 - - if impl(ghc >= 6.11) && impl(ghc < 8.11) - if !flag(integer-simple) - cpp-options: -DINTEGER_GMP - build-depends: integer-gmp >= 0.2 - - if impl(ghc >= 6.9) && impl(ghc < 6.11) - cpp-options: -DINTEGER_GMP - build-depends: integer >= 0.1 && < 0.2 - -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 - -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 - -test-suite test-builder +test-suite bytestring-tests 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 + QuickCheckUtils + hs-source-dirs: tests, + tests/builder + build-depends: base, + bytestring, deepseq, - dlist >= 0.5 && < 0.9, - transformers >= 0.3, + ghc-prim, + QuickCheck, tasty, - tasty-hunit, - tasty-quickcheck - if impl(ghc < 8.4) - build-depends: ghc-byteorder - ghc-options: -Wall -fwarn-tabs -threaded -rtsopts + tasty-quickcheck, + template-haskell, + transformers >= 0.3 + ghc-options: -fwarn-unused-binds + -threaded -rtsopts default-language: Haskell2010 benchmark bytestring-bench main-is: BenchAll.hs other-modules: BenchBoundsCheckFusion + BenchCount BenchCSV BenchIndices type: exitcode-stdio-1.0 hs-source-dirs: bench default-language: Haskell2010 - ghc-options: -O2 + ghc-options: -O2 "-with-rtsopts=-A32m" 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,280 @@ +/* +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 all_80 = vdupq_n_u8(0x80); + // A non-ASCII byte will have its highest-order bit set. Since this is + // preserved by OR, we can OR everything together. + uint8x16_t ored = vorrq_u8(vorrq_u8(inputs[0], inputs[1]), + vorrq_u8(inputs[2], inputs[3])); + // ANDing with 0x80 retains any set high-order bits. We then check for zeroes. + uint64x2_t result = vreinterpretq_u64_u8(vandq_u8(ored, all_80)); + 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 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); + // We cast this pointer to avoid a redundant check against < 127, as any such + // value would be negative in signed form. + int8_t const * token_ptr = (int8_t const *)&token; + ptrdiff_t lookahead = 0; + if (token_ptr[3] > (int8_t)0xBF) { + lookahead = 1; + } + else if (token_ptr[2] > (int8_t)0xBF) { + lookahead = 2; + } + else if (token_ptr[1] > (int8_t)0xBF) { + lookahead = 3; + } + // Finish the job. + uint8_t const * const small_ptr = ptr - lookahead; + size_t const small_len = remaining + lookahead; + return is_valid_utf8_fallback(small_ptr, small_len); +} + +#pragma GCC pop_options diff --git a/cbits/fpstring.c b/cbits/fpstring.c --- a/cbits/fpstring.c +++ b/cbits/fpstring.c @@ -31,10 +31,17 @@ #include "fpstring.h" #if defined(__x86_64__) -#include -#include +#include +#include #endif +#include +#include + +#ifndef __STDC_NO_ATOMICS__ +#include +#endif + /* copy a string in reverse */ void fps_reverse(unsigned char *q, unsigned char *p, size_t n) { p += n-1; @@ -90,26 +97,190 @@ return c; } +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); +} + /* count the number of occurences of a char in a string */ -size_t fps_count(unsigned char *p, size_t len, unsigned char w) { +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); +#if defined(__x86_64__) && (__GNUC__ >= 6 || defined(__clang_major__)) && !defined(__STDC_NO_ATOMICS__) +#define USE_SIMD_COUNT +#endif + +#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,696 @@ +/* +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 + +#ifdef __x86_64__ +#include +#include +#include +#include +#endif + +#ifndef __STDC_NO_ATOMICS__ +#include +#endif + +#include + +#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 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(*big_ptr) & high_bits_mask, + to_little_endian(*(big_ptr + 1)) & high_bits_mask, + to_little_endian(*(big_ptr + 2)) & high_bits_mask, + to_little_endian(*(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 += (__builtin_ctzl(results[3]) / 8); + } + } else { + ptr += (__builtin_ctzl(results[2]) / 8); + } + } else { + ptr += (__builtin_ctzl(results[1]) / 8); + } + } else { + ptr += (__builtin_ctzl(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; +} + +#ifdef __x86_64__ + +// 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 | 4 | 4 | 8 | +// +------------+---------------+------------------+----------------+ +// 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) { + // OR together everything, then check for a high bit anywhere. + __m128i const ored = + _mm_or_si128(_mm_or_si128(src[0], src[1]), _mm_or_si128(src[2], src[3])); + 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 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. + int16_t tokens[2]; + tokens[0] = _mm_extract_epi16(prev_input, 6); + tokens[1] = _mm_extract_epi16(prev_input, 7); + int8_t const *token_ptr = (int8_t const *)tokens; + ptrdiff_t lookahead = 0; + if (token_ptr[3] > (int8_t)0xBF) { + lookahead = 1; + } else if (token_ptr[2] > (int8_t)0xBF) { + lookahead = 2; + } else if (token_ptr[1] > (int8_t)0xBF) { + lookahead = 3; + } + uint8_t const *const small_ptr = ptr - lookahead; + size_t const small_len = remaining + lookahead; + 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. + bool is_ascii = _mm256_movemask_epi8(_mm256_or_si256( + _mm256_or_si256(inputs[0], inputs[1]), + _mm256_or_si256(inputs[2], inputs[3]))) == 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); + int8_t const *tokens = (int8_t const *)&tokens_blob; + ptrdiff_t lookahead = 0; + if (tokens[3] > (int8_t)0xBF) { + lookahead = 1; + } else if (tokens[2] > (int8_t)0xBF) { + lookahead = 2; + } else if (tokens[1] > (int8_t)0xBF) { + lookahead = 3; + } + uint8_t const *const small_ptr = ptr - lookahead; + size_t const small_len = remaining + lookahead; + return is_valid_utf8_fallback(small_ptr, small_len); +} + +#endif + +#ifdef __x86_64__ +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; + } +#ifdef __x86_64__ + 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/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,301 @@ +{-# LANGUAGE LambdaCase #-} + +module IsValidUtf8 (testSuite) where + +import Data.Bits (shiftR, (.&.), shiftL) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Char (chr, ord) +import Data.Word (Word8) +import GHC.Exts (fromList) +import Test.QuickCheck (Property, forAll, (===)) +import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary, shrink)) +import Test.QuickCheck.Gen (oneof, Gen, choose, vectorOf, listOf1, sized, resize, + elements) +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" $ goValid, + adjustOption (max testCount) . testProperty "Invalid UTF-8" $ goInvalid, + testGroup "Regressions" checkRegressions + ] + where + goValid :: Property + goValid = forAll arbitrary $ + \(ValidUtf8 ss) -> (B.isValidUtf8 . foldMap sequenceToBS $ ss) === True + goInvalid :: Property + goInvalid = forAll arbitrary $ + \inv -> (B.isValidUtf8 . toByteString $ inv) === False + testCount :: QuickCheckTests + testCount = 1000 + +checkRegressions :: [TestTree] +checkRegressions = [ + testProperty "Too high code point" $ not $ B.isValidUtf8 tooHigh + ] + 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 + +-- Helpers + +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 [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 <$> shrinkBS s) ++ + ((\p' -> InvalidUtf8 p' i s) <$> shrinkBS 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 + ] + 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] + +shrinkBS :: ByteString -> [ByteString] +shrinkBS bs = 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,62 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +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 +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 + ] + ] 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,498 @@ -{-# 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 BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Properties (testSuite) where + +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.Int (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 Prelude hiding (abs) + +import QuickCheckUtils +import Test.Tasty +import Test.Tasty.QuickCheck + +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_head2BB xs = (not (null xs)) ==> head xs == (P.unsafeHead . P.pack) xs + +prop_tail1BB xs = (not (null xs)) ==> tail xs == (P.unpack . P.unsafeTail. P.pack) xs + +prop_last1BB xs = (not (null xs)) ==> last xs == (P.unsafeLast . P.pack) xs + +prop_init1BB xs = + (not (null xs)) ==> + init xs == (P.unpack . P.unsafeInit . P.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_strip x = C.strip x == (C.dropSpace . C.reverse . C.dropSpace . C.reverse) x + +-- 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_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 "StrictWord8" PropBS.tests + , testGroup "StrictChar8" PropBS8.tests + , testGroup "LazyWord8" PropBL.tests + , testGroup "LazyChar8" PropBL8.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 + ] + +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_head2BB + , testProperty "unsafeTail" prop_tail1BB + , testProperty "unsafeLast" prop_last1BB + , testProperty "unsafeInit" prop_init1BB + , testProperty "unsafeIndex" prop_unsafeIndexBB + + , testProperty "lines_lazy1" prop_lines_lazy1 + , testProperty "lines_lazy2" prop_lines_lazy2 + , testProperty "strip" prop_strip + , testProperty "isSpace" prop_isSpaceWord8 + + , testProperty "readIntSafe" prop_readIntSafe + , testProperty "readIntUnsafe" prop_readIntUnsafe + , testProperty "readIntegerSafe" prop_readIntegerSafe + , testProperty "readIntegerUnsafe" prop_readIntegerUnsafe + ] + +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 (+)) . tail . 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 (+.)) . tail . D.inits) xs + ] + ] 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,622 @@ +-- | +-- Module : Properties.ByteString +-- Copyright : (c) Andrew Lelechenko 2021 +-- License : BSD-style + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} + +-- 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 + +#ifndef BYTESTRING_LAZY +module Properties.ByteString (tests) where +import qualified Data.ByteString as B +import GHC.IO.Encoding +#else +module Properties.ByteStringLazy (tests) where +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Lazy.Internal as B (invariant) +#endif + +import Data.Word + +#else + +#ifndef BYTESTRING_LAZY +module Properties.ByteStringChar8 (tests) where +import qualified Data.ByteString.Char8 as B +#else +module Properties.ByteStringLazyChar8 (tests) where +import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.ByteString.Lazy.Internal as B (invariant) +#endif + +import Text.Read + +#endif + +import Control.Arrow +import Data.Char +import Data.Foldable +import qualified Data.List as List +import Data.Semigroup +import Data.String +import Data.Tuple +import Test.Tasty +import Test.Tasty.QuickCheck +import QuickCheckUtils + +#ifndef BYTESTRING_CHAR8 +toElem :: Word8 -> Word8 +toElem = id +#else +toElem :: Char8 -> Char +toElem (Char8 c) = c +#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 :: B.ByteString) === read (show x) + , testProperty "fromStrict . toStrict" $ + \x -> B.fromStrict (B.toStrict x) === x + , testProperty "toStrict . fromStrict" $ + \x -> B.toStrict (B.fromStrict x) === x +#ifndef BYTESTRING_LAZY +#ifndef BYTESTRING_CHAR8 + , 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) + _ -> property prop +#endif +#endif + + , testProperty "==" $ + \x y -> (x == y) === (B.unpack x == B.unpack y) + , testProperty "== refl" $ + \x -> (x :: B.ByteString) == x + , testProperty "== symm" $ + \x y -> ((x :: B.ByteString) == y) === (y == x) + , testProperty "== pack unpack" $ + \x -> x == B.pack (B.unpack x) + , testProperty "== copy" $ + \x -> x == B.copy x + + , testProperty "compare" $ + \x y -> compare x y === compare (B.unpack x) (B.unpack y) + , testProperty "compare EQ" $ + \x -> compare (x :: B.ByteString) 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) + , 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 "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 :: B.ByteString) === mtimesDefault 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 + + , 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) + + , 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" $ + \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" $ + \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" $ + \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" $ + \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 "invariant" $ + \x -> B.invariant x + , 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 <> undefined) === 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 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 <> undefined)) === B.singleton c + , testProperty "dropWhileEnd lazy" $ + \(toElem -> c) -> B.take 1 (B.dropWhileEnd (const False) (B.singleton c <> undefined)) === B.singleton c + , testProperty "breakEnd lazy" $ + \(toElem -> c) -> B.take 1 (fst $ B.breakEnd (const True) (B.singleton c <> undefined)) === B.singleton c + , testProperty "spanEnd lazy" $ + \(toElem -> c) -> B.take 1 (fst $ B.spanEnd (const False) (B.singleton c <> undefined)) === 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)) + , testProperty "findIndexEnd" $ + \f x -> B.findIndexEnd f x === fmap fromIntegral (findIndexEnd f (B.unpack x)) + , 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) + , testProperty "notElem" $ + \(toElem -> c) x -> B.notElem c x === notElem c (B.unpack x) + , testProperty "elemIndex" $ + \(toElem -> c) x -> B.elemIndex c x === fmap fromIntegral (List.elemIndex c (B.unpack x)) + , testProperty "elemIndexEnd" $ + \(toElem -> c) x -> B.elemIndexEnd c x === fmap fromIntegral (elemIndexEnd c (B.unpack x)) + , 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" $ + \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 -> not (B.null x) ==> B.head x === head (B.unpack x) + , testProperty "last" $ + \x -> not (B.null x) ==> B.last x === last (B.unpack x) + , testProperty "tail" $ + \x -> not (B.null x) ==> B.unpack (B.tail x) === tail (B.unpack x) + , 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) + , 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) + + , 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 + + , 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 + +#ifndef BYTESTRING_LAZY + , testProperty "sort" $ + \x -> B.unpack (B.sort x) === List.sort (B.unpack x) +#endif + + , testProperty "intersperse" $ + \(toElem -> c) x -> B.unpack (B.intersperse c x) === List.intersperse c (B.unpack x) + , 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 + + , 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) + , testProperty "unzip" $ + \(fmap (toElem *** toElem) -> xs) -> (B.unpack *** B.unpack) (B.unzip xs) === unzip xs + + , testProperty "index" $ + \(NonNegative n) x -> fromIntegral n < B.length x ==> B.index x (fromIntegral n) === B.unpack x !! n + , testProperty "indexMaybe" $ + \(NonNegative n) x -> fromIntegral n < B.length x ==> B.indexMaybe x (fromIntegral n) === Just (B.unpack x !! n) + , testProperty "indexMaybe Nothing" $ + \n x -> (n :: Int) < 0 || fromIntegral n >= B.length x ==> B.indexMaybe x (fromIntegral n) === Nothing + , testProperty "!?" $ + \n x -> B.indexMaybe x (fromIntegral (n :: Int)) === x B.!? (fromIntegral n) + +#ifdef BYTESTRING_CHAR8 + , testProperty "isString" $ + \x -> x === fromString (B.unpack x) + , testProperty "readInt 1" $ + \x -> fmap (second B.unpack) (B.readInt x) === readInt (B.unpack x) + , testProperty "readInt 2" $ + \n -> B.readInt (B.pack (show n)) === Just (n, B.empty) + , testProperty "readInteger 1" $ + \x -> fmap (second B.unpack) (B.readInteger x) === readInteger (B.unpack x) + , testProperty "readInteger 2" $ + \n -> B.readInteger (B.pack (show n)) === Just (n, B.empty) + , 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 + ] + +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc xs = Just (init xs, last xs) + +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)) + +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 + +readInteger :: String -> Maybe (Integer, String) +readInteger ('+' : xs) = readIntegerUnsigned xs +readInteger ('-' : xs) = fmap (first negate) (readIntegerUnsigned xs) +readInteger xs = readIntegerUnsigned xs + +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 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/QuickCheckUtils.hs b/tests/QuickCheckUtils.hs --- a/tests/QuickCheckUtils.hs +++ b/tests/QuickCheckUtils.hs @@ -1,17 +1,19 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, - FlexibleInstances, FlexibleContexts, - TypeSynonymInstances #-} --- --- Uses multi-param type classes --- -module QuickCheckUtils where +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +module QuickCheckUtils + ( Char8(..) + , String8(..) + , CByteString(..) + , Sqrt(..) + ) 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 @@ -34,6 +36,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) @@ -72,6 +75,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 +90,14 @@ where toChar :: Word8 -> Char toChar = toEnum . fromIntegral - ------------------------------------------------------------------------- --- --- 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 - --- | 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 - --- --- 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 - --- Some short hand. -type X = Int -type W = Word8 -type P = P.ByteString -type B = L.ByteString - ------------------------------------------------------------------------- --- --- 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 --- - -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) + shrink (String8 xs) = fmap String8 (shrink xs) --- --- 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 +-- | 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) -class IsNull t where isNull :: t -> Bool -instance IsNull L.ByteString where isNull = L.null -instance IsNull P.ByteString where isNull = P.null +instance Arbitrary a => Arbitrary (Sqrt a) where + arbitrary = Sqrt <$> sized + (\n -> resize (round @Double $ sqrt $ fromIntegral @Int n) arbitrary) + shrink = map Sqrt . shrink . unSqrt 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,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Copyright : (c) 2011 Simon Meier @@ -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/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,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -14,6 +15,8 @@ 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) @@ -23,8 +26,11 @@ import Foreign (minusPtr) import Data.Char (chr) -import qualified Data.DList as D +import Data.Bits ((.|.), shiftL) import Data.Foldable +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup +#endif import Data.Word import qualified Data.ByteString as S @@ -43,12 +49,14 @@ 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, UnicodeString(..), Property, testProperty + , (===), (.&&.), conjoin ) tests :: [TestTree] @@ -58,10 +66,12 @@ , testHandlePutBuilderChar8 , testPut , testRunBuilder + , testWriteFile ] ++ testsEncodingToBuilder ++ testsBinary ++ testsASCII ++ + testsFloating ++ testsChar8 ++ testsUtf8 @@ -94,20 +104,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 +173,32 @@ 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 + removeFile :: String -> IO () removeFile fn = void $ withCString fn c_unlink @@ -207,31 +233,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 @@ -600,6 +640,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 = 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 - ]