bytestring 0.11.5.4 → 0.12.0.0
raw patch · 21 files changed
+1459/−520 lines, 21 filesdep +data-array-bytePVP ok
version bump matches the API change (PVP)
Dependencies added: data-array-byte
API changes (from Hackage documentation)
- Data.ByteString.Short: SBS :: ByteArray# -> ShortByteString
- Data.ByteString.Short: data ShortByteString
- Data.ByteString.Short.Internal: SBS :: ByteArray# -> ShortByteString
- Data.ByteString.Short.Internal: data ShortByteString
+ Data.ByteString.Char8: readInt16 :: ByteString -> Maybe (Int16, ByteString)
+ Data.ByteString.Char8: readInt32 :: ByteString -> Maybe (Int32, ByteString)
+ Data.ByteString.Char8: readInt64 :: ByteString -> Maybe (Int64, ByteString)
+ Data.ByteString.Char8: readInt8 :: ByteString -> Maybe (Int8, ByteString)
+ Data.ByteString.Char8: readNatural :: ByteString -> Maybe (Natural, ByteString)
+ Data.ByteString.Char8: readWord :: ByteString -> Maybe (Word, ByteString)
+ Data.ByteString.Char8: readWord16 :: ByteString -> Maybe (Word16, ByteString)
+ Data.ByteString.Char8: readWord32 :: ByteString -> Maybe (Word32, ByteString)
+ Data.ByteString.Char8: readWord64 :: ByteString -> Maybe (Word64, ByteString)
+ Data.ByteString.Char8: readWord8 :: ByteString -> Maybe (Word8, ByteString)
+ Data.ByteString.Internal: checkedMultiply :: String -> Int -> Int -> Int
+ Data.ByteString.Internal: data SizeOverflowException
+ Data.ByteString.Internal: overflowError :: String -> a
+ Data.ByteString.Lazy.Char8: readInt16 :: ByteString -> Maybe (Int16, ByteString)
+ Data.ByteString.Lazy.Char8: readInt32 :: ByteString -> Maybe (Int32, ByteString)
+ Data.ByteString.Lazy.Char8: readInt64 :: ByteString -> Maybe (Int64, ByteString)
+ Data.ByteString.Lazy.Char8: readInt8 :: ByteString -> Maybe (Int8, ByteString)
+ Data.ByteString.Lazy.Char8: readNatural :: ByteString -> Maybe (Natural, ByteString)
+ Data.ByteString.Lazy.Char8: readWord :: ByteString -> Maybe (Word, ByteString)
+ Data.ByteString.Lazy.Char8: readWord16 :: ByteString -> Maybe (Word16, ByteString)
+ Data.ByteString.Lazy.Char8: readWord32 :: ByteString -> Maybe (Word32, ByteString)
+ Data.ByteString.Lazy.Char8: readWord64 :: ByteString -> Maybe (Word64, ByteString)
+ Data.ByteString.Lazy.Char8: readWord8 :: ByteString -> Maybe (Word8, ByteString)
+ Data.ByteString.Short: ShortByteString :: ByteArray -> ShortByteString
+ Data.ByteString.Short: [unShortByteString] :: ShortByteString -> ByteArray
+ Data.ByteString.Short: newtype ShortByteString
+ Data.ByteString.Short: pattern SBS :: ByteArray# -> ShortByteString
+ Data.ByteString.Short.Internal: ShortByteString :: ByteArray -> ShortByteString
+ Data.ByteString.Short.Internal: [unShortByteString] :: ShortByteString -> ByteArray
+ Data.ByteString.Short.Internal: newtype ShortByteString
+ Data.ByteString.Short.Internal: pattern SBS :: ByteArray# -> ShortByteString
Files
- Changelog.md +28/−23
- Data/ByteString.hs +18/−15
- Data/ByteString/Builder/Internal.hs +4/−4
- Data/ByteString/Char8.hs +25/−86
- Data/ByteString/Internal.hs +3/−0
- Data/ByteString/Internal/Type.hs +146/−48
- Data/ByteString/Lazy/Char8.hs +25/−92
- Data/ByteString/Lazy/Internal.hs +2/−2
- Data/ByteString/Lazy/ReadInt.hs +264/−0
- Data/ByteString/Lazy/ReadNat.hs +257/−0
- Data/ByteString/ReadInt.hs +3/−0
- Data/ByteString/ReadNat.hs +3/−0
- Data/ByteString/Short/Internal.hs +84/−112
- bench/BenchAll.hs +8/−0
- bench/BenchReadInt.hs +144/−0
- bytestring.cabal +9/−1
- cbits/aarch64/is-valid-utf8.c +12/−16
- cbits/is-valid-utf8.c +30/−68
- tests/IsValidUtf8.hs +27/−36
- tests/Properties.hs +246/−7
- tests/Properties/ByteString.hs +121/−10
Changelog.md view
@@ -1,30 +1,35 @@-[0.11.5.4] — January 2025+[0.12.0.0] — July 2023 +* __Breaking Changes__:+ * [`readInt` returns `Nothing`, if the sequence of digits cannot be represented by an `Int`, instead of overflowing silently](https://github.com/haskell/bytestring/pull/309)+ * [Remove `zipWith` rewrite rule](https://github.com/haskell/bytestring/pull/387)+ * [`ShortByteString` is now a wrapper around `Data.Array.Byte.ByteArray` instead of `ByteArray#` directly](https://github.com/haskell/bytestring/pull/410)+ * As a compatibility measure, `SBS` remains available as a pattern synonym.+ * The compatibility package `data-array-byte` is used when `base` does not provide `Data.Array.Byte`.+ * [`fromListN` from `instance IsList ShortByteString` now throws an exception if the first argument does not match the length of the second](https://github.com/haskell/bytestring/pull/410)+ * Previously, it would ignore the first argument entirely. * Bug fixes:- * [`Builder`: avoid unsound buffer reuse, introduced in `bytestring-0.11.5.0`](https://github.com/haskell/bytestring/pull/691)+ * Size-related calculations are more resistant to `Int` overflow in the following places:+ * [`Data.ByteString.intercalate`](https://github.com/haskell/bytestring/pull/468)+ * [`stimes @StrictByteString`](https://github.com/haskell/bytestring/pull/443)+ * [`Data.ByteString.Short.concat`](https://github.com/haskell/bytestring/pull/443)+ * [`Data.ByteString.Short.append`](https://github.com/haskell/bytestring/pull/443)+ * [`Data.ByteString.Short.snoc`](https://github.com/haskell/bytestring/pull/599)+ * [`Data.ByteString.Short.cons`](https://github.com/haskell/bytestring/pull/599)+* API additions:+ * [New sized and/or unsigned variants of `readInt` and `readInteger`](https://github.com/haskell/bytestring/pull/438)+ * [`Data.ByteString.Internal` now provides `SizeOverflowException`, `overflowError`, and `checkedMultiply`](https://github.com/haskell/bytestring/pull/443)+* Deprecations:+ * `Data.ByteString.getLine`: prefer `Data.ByteString.Char8.getLine`+ * `Data.ByteString.hGetLine`: prefer `Data.ByteString.Char8.hGetLine`+<!--+* Performance improvements:+* Miscellaneous:+* Internal stuff:+--> -[0.11.5.4]: https://github.com/haskell/bytestring/compare/0.11.5.3...0.11.5.4 -[0.11.5.3] — October 2023--* Bug fixes:- * [Fix a bug in `isValidUtf8`](https://github.com/haskell/bytestring/pull/621)--[0.11.5.3]: https://github.com/haskell/bytestring/compare/0.11.5.2...0.11.5.3--[0.11.5.2] — August 2023--* Bug fixes:- * [Fix `clockid_t`-related build failures on some platforms](https://github.com/haskell/bytestring/pull/607)--[0.11.5.2]: https://github.com/haskell/bytestring/compare/0.11.5.1...0.11.5.2--[0.11.5.1] — August 2023--* Bug fixes:- * [Work around a GHC runtime linker issue on i386/PowerPC](https://github.com/haskell/bytestring/pull/604)--[0.11.5.1]: https://github.com/haskell/bytestring/compare/0.11.5.0...0.11.5.1+[0.12.0.0]: https://github.com/haskell/bytestring/compare/0.11.5.0...0.12.0.0 [0.11.5.0] — July 2023
Data/ByteString.hs view
@@ -380,16 +380,16 @@ -- | /O(n)/ 'cons' is analogous to (:) for lists, but of different -- complexity, as it requires making a copy. cons :: Word8 -> ByteString -> ByteString-cons c (BS x l) = unsafeCreateFp (l+1) $ \p -> do+cons c (BS x len) = unsafeCreateFp (checkedAdd "cons" len 1) $ \p -> do pokeFp p c- memcpyFp (p `plusForeignPtr` 1) x l+ memcpyFp (p `plusForeignPtr` 1) x len {-# INLINE cons #-} -- | /O(n)/ Append a byte to the end of a 'ByteString' snoc :: ByteString -> Word8 -> ByteString-snoc (BS x l) c = unsafeCreateFp (l+1) $ \p -> do- memcpyFp p x l- pokeFp (p `plusForeignPtr` l) c+snoc (BS x len) c = unsafeCreateFp (checkedAdd "snoc" len 1) $ \p -> do+ memcpyFp p x len+ pokeFp (p `plusForeignPtr` len) c {-# INLINE snoc #-} -- | /O(1)/ Extract the first element of a ByteString, which must be non-empty.@@ -773,7 +773,7 @@ -- ^ input of length n -> ByteString -- ^ output of length n+1-scanl f v = \(BS a len) -> unsafeCreateFp (len+1) $ \q -> do+scanl f v = \(BS a len) -> unsafeCreateFp (checkedAdd "scanl" len 1) $ \q -> do -- see fold inlining pokeFp q v let@@ -817,7 +817,7 @@ -- ^ input of length n -> ByteString -- ^ output of length n+1-scanr f v = \(BS a len) -> unsafeCreateFp (len+1) $ \b -> do+scanr f v = \(BS a len) -> unsafeCreateFp (checkedAdd "scanr" len 1) $ \b -> do -- see fold inlining pokeFpByteOff b len v let@@ -1228,8 +1228,9 @@ go (destPtr' `plusForeignPtr` chunkLen) chunks go (dstPtr0 `plusForeignPtr` hLen) t where- totalLen = List.foldl' (\acc (BS _ chunkLen) -> acc + chunkLen + sepLen) hLen t-{-# INLINE intercalate #-}+ totalLen = List.foldl' (\acc chunk -> acc +! sepLen +! length chunk) hLen t+ (+!) = checkedAdd "intercalate"+{-# INLINABLE intercalate #-} -- --------------------------------------------------------------------- -- Indexing ByteStrings@@ -1680,11 +1681,6 @@ len = min l m {-# INLINE packZipWith #-} -{-# RULES-"ByteString specialise zipWith" forall (f :: Word8 -> Word8 -> Word8) p q .- zipWith f p q = unpack (packZipWith f p q)- #-}- -- | /O(n)/ 'unzip' transforms a list of pairs of bytes into a pair of -- ByteStrings. Note that this performs two 'pack' operations. unzip :: [(Word8,Word8)] -> (ByteString,ByteString)@@ -1830,8 +1826,11 @@ getLine :: IO ByteString getLine = hGetLine stdin --- | Read a line from a handle+{-# DEPRECATED getLine+ "Deprecated since @bytestring-0.12@. Use 'Data.ByteString.Char8.getLine' instead. (Functions that rely on ASCII encodings belong in \"Data.ByteString.Char8\")"+ #-} +-- | Read a line from a handle hGetLine :: Handle -> IO ByteString hGetLine h = wantReadableHandle_ "Data.ByteString.hGetLine" h $@@ -1877,6 +1876,10 @@ if c == fromIntegral (ord '\n') then return r -- NB. not r+1: don't include the '\n' else findEOL (r+1) w raw++{-# DEPRECATED hGetLine+ "Deprecated since @bytestring-0.12@. Use 'Data.ByteString.Char8.hGetLine' instead. (Functions that rely on ASCII encodings belong in \"Data.ByteString.Char8\")"+ #-} mkPS :: RawBuffer Word8 -> Int -> Int -> IO ByteString mkPS buf start end =
Data/ByteString/Builder/Internal.hs view
@@ -1096,7 +1096,7 @@ -- Checking for empty case avoids allocating 'n-1' empty -- buffers for 'n' insertChunkH right after each other. if isEmpty- then fill nextStep buf+ then fill nextStep (Buffer fpbuf (BufferRange pbuf pe)) else do buf' <- nextBuffer (Just (buf, bufSize)) fill nextStep buf' @@ -1108,9 +1108,9 @@ | trim chunkSize size = do bs <- S.createFp chunkSize $ \fpbuf' -> S.memcpyFp fpbuf' fpbuf chunkSize- -- It is not safe to re-use the old buffer (see #690),- -- so we allocate a new buffer after trimming.- return $ Yield1 bs (mkCIOS False)+ -- Instead of allocating a new buffer after trimming,+ -- we re-use the old buffer and consider it empty.+ return $ Yield1 bs (mkCIOS True) | otherwise = return $ Yield1 (S.BS fpbuf chunkSize) (mkCIOS False) where
Data/ByteString/Char8.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE MagicHash #-} {-# OPTIONS_HADDOCK prune #-} {-# LANGUAGE Trustworthy #-}+{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Data.ByteString.Char8@@ -187,7 +188,19 @@ -- * Reading from ByteStrings readInt,+ readInt64,+ readInt32,+ readInt16,+ readInt8,++ readWord,+ readWord64,+ readWord32,+ readWord16,+ readWord8,+ readInteger,+ readNatural, -- * Low level CString conversions @@ -257,15 +270,17 @@ ,isInfixOf,stripPrefix,stripSuffix ,breakSubstring,copy,group - ,getLine, getContents, putStr, interact+ ,getContents, putStr, interact ,readFile, writeFile, appendFile ,hGetContents, hGet, hGetSome, hPut, hPutStr- ,hGetLine, hGetNonBlocking, hPutNonBlocking+ ,hGetNonBlocking, hPutNonBlocking ,packCString,packCStringLen ,useAsCString,useAsCStringLen ) import Data.ByteString.Internal.Type+import Data.ByteString.ReadInt+import Data.ByteString.ReadNat import Data.Char ( isSpace ) -- See bytestring #70@@ -845,14 +860,6 @@ unzip ls = (pack (P.map fst ls), pack (P.map snd ls)) {-# INLINE unzip #-} --- | A variety of 'head' for non-empty ByteStrings. 'unsafeHead' omits--- the check for the empty case, which is good for performance, but--- there is an obligation on the programmer to provide a proof that the--- ByteString is non-empty.-unsafeHead :: ByteString -> Char-unsafeHead = w2c . B.unsafeHead-{-# INLINE unsafeHead #-}- -- --------------------------------------------------------------------- -- Things that depend on the encoding @@ -988,84 +995,16 @@ unwords = intercalate (singleton ' ') {-# INLINE unwords #-} --- ------------------------------------------------------------------------ Reading from ByteStrings---- | readInt reads an Int from the beginning of the ByteString. If there is no--- integer at the beginning of the string, it returns Nothing, otherwise--- it just returns the int read, and the rest of the string.------ Note: This function will overflow the Int for large integers.-readInt :: ByteString -> Maybe (Int, ByteString)-readInt as- | null as = Nothing- | otherwise =- case unsafeHead as of- '-' -> loop True 0 0 (B.unsafeTail as)- '+' -> loop False 0 0 (B.unsafeTail as)- _ -> loop False 0 0 as-- where loop :: Bool -> Int -> Int -> ByteString -> Maybe (Int, ByteString)- loop neg !i !n !ps- | null ps = end neg i n ps- | otherwise =- case B.unsafeHead ps of- w | w >= 0x30- && w <= 0x39 -> loop neg (i+1)- (n * 10 + (fromIntegral w - 0x30))- (B.unsafeTail ps)- | otherwise -> end neg i n ps-- end _ 0 _ _ = Nothing- end True _ n ps = Just (negate n, ps)- end _ _ n ps = Just (n, ps)---- | readInteger reads an Integer from the beginning of the ByteString. If--- there is no integer at the beginning of the string, it returns Nothing,--- otherwise it just returns the int read, and the rest of the string.-readInteger :: ByteString -> Maybe (Integer, ByteString)-readInteger as- | null as = Nothing- | otherwise =- case unsafeHead as of- '-' -> first (B.unsafeTail as) >>= \(n, bs) -> return (-n, bs)- '+' -> first (B.unsafeTail as)- _ -> first as-- where first ps | null ps = Nothing- | otherwise =- case B.unsafeHead ps of- w | w >= 0x30 && w <= 0x39 -> Just $- loop 1 (fromIntegral w - 0x30) [] (B.unsafeTail ps)- | otherwise -> Nothing-- loop :: Int -> Int -> [Integer]- -> ByteString -> (Integer, ByteString)- loop !d !acc ns !ps- | null ps = combine d acc ns empty- | otherwise =- case B.unsafeHead ps of- w | w >= 0x30 && w <= 0x39 ->- if d == 9 then loop 1 (fromIntegral w - 0x30)- (toInteger acc : ns)- (B.unsafeTail ps)- else loop (d+1)- (10*acc + (fromIntegral w - 0x30))- ns (B.unsafeTail ps)- | otherwise -> combine d acc ns ps-- combine _ acc [] ps = (toInteger acc, ps)- combine d acc ns ps =- (10^d * combine1 1000000000 ns + toInteger acc, ps)-- combine1 _ [n] = n- combine1 b ns = combine1 (b*b) $ combine2 b ns-- combine2 b (n:m:ns) = let !t = m*b + n in t : combine2 b ns- combine2 _ ns = ns- ------------------------------------------------------------------------ -- For non-binary text processing:++-- | Read a line from stdin.+getLine :: IO ByteString+getLine = B.getLine++-- | Read a line from a handle+hGetLine :: Handle -> IO ByteString+hGetLine = B.hGetLine -- | Write a ByteString to a handle, appending a newline byte. --
Data/ByteString/Internal.hs view
@@ -60,7 +60,10 @@ -- * Utilities nullForeignPtr, deferForeignPtrAvailability,+ SizeOverflowException,+ overflowError, checkedAdd,+ checkedMultiply, -- * Standard C Functions c_strlen,
Data/ByteString/Internal/Type.hs view
@@ -78,7 +78,10 @@ memcpyFp, deferForeignPtrAvailability, unsafeDupablePerformIO,+ SizeOverflowException,+ overflowError, checkedAdd,+ checkedMultiply, -- * Standard C Functions c_strlen,@@ -118,18 +121,17 @@ import Foreign.C.String (CString) import Foreign.Marshal.Utils -#if MIN_VERSION_base(4,13,0)-import Data.Semigroup (Semigroup (sconcat, stimes))-#else-import Data.Semigroup (Semigroup ((<>), sconcat, stimes))+#if !MIN_VERSION_base(4,13,0)+import Data.Semigroup (Semigroup ((<>))) #endif+import Data.Semigroup (Semigroup (sconcat, stimes)) import Data.List.NonEmpty (NonEmpty ((:|))) import Control.DeepSeq (NFData(rnf)) import Data.String (IsString(..)) -import Control.Exception (assert)+import Control.Exception (assert, throw, Exception) import Data.Bits ((.&.)) import Data.Char (ord)@@ -142,6 +144,19 @@ import GHC.CString (unpackCString#) import GHC.Magic (runRW#, lazy) +#define TIMES_INT_2_AVAILABLE MIN_VERSION_ghc_prim(0,7,0)+#if TIMES_INT_2_AVAILABLE+import GHC.Prim (timesInt2#)+#else+import GHC.Prim ( timesWord2#+ , or#+ , uncheckedShiftRL#+ , int2Word#+ , word2Int#+ )+import Data.Bits (finiteBitSize)+#endif+ import GHC.IO (IO(IO)) import GHC.ForeignPtr (ForeignPtr(ForeignPtr) #if __GLASGOW_HASKELL__ < 900@@ -308,7 +323,8 @@ instance Semigroup ByteString where (<>) = append sconcat (b:|bs) = concat (b:bs)- stimes = times+ {-# INLINE stimes #-}+ stimes = stimesPolymorphic instance Monoid ByteString where mempty = empty@@ -637,30 +653,30 @@ -- | Create ByteString of size @l@ and use action @f@ to fill its contents. createFp :: Int -> (ForeignPtr Word8 -> IO ()) -> IO ByteString-createFp l action = do- fp <- mallocByteString l+createFp len action = assert (len >= 0) $ do+ fp <- mallocByteString len action fp- mkDeferredByteString fp l+ mkDeferredByteString fp len {-# INLINE createFp #-} -- | Given a maximum size @l@ and an action @f@ that fills the 'ByteString' -- starting at the given 'Ptr' and returns the actual utilized length, -- @`createFpUptoN'` l f@ returns the filled 'ByteString'. createFpUptoN :: Int -> (ForeignPtr Word8 -> IO Int) -> IO ByteString-createFpUptoN l action = do- fp <- mallocByteString l- l' <- action fp- assert (l' <= l) $ mkDeferredByteString fp l'+createFpUptoN maxLen action = assert (maxLen >= 0) $ do+ fp <- mallocByteString maxLen+ len <- action fp+ assert (0 <= len && len <= maxLen) $ mkDeferredByteString fp len {-# INLINE createFpUptoN #-} -- | Like 'createFpUptoN', but also returns an additional value created by the -- action. createFpUptoN' :: Int -> (ForeignPtr Word8 -> IO (Int, a)) -> IO (ByteString, a)-createFpUptoN' l action = do- fp <- mallocByteString l- (l', res) <- action fp- bs <- mkDeferredByteString fp l'- assert (l' <= l) $ pure (bs, res)+createFpUptoN' maxLen action = assert (maxLen >= 0) $ do+ fp <- mallocByteString maxLen+ (len, res) <- action fp+ bs <- mkDeferredByteString fp len+ assert (0 <= len && len <= maxLen) $ pure (bs, res) {-# INLINE createFpUptoN' #-} -- | Given the maximum size needed and a function to make the contents@@ -672,22 +688,26 @@ -- ByteString functions, using Haskell or C functions to fill the space. -- createFpAndTrim :: Int -> (ForeignPtr Word8 -> IO Int) -> IO ByteString-createFpAndTrim l action = do- fp <- mallocByteString l- l' <- action fp- if assert (0 <= l' && l' <= l) $ l' >= l- then mkDeferredByteString fp l- else createFp l' $ \dest -> memcpyFp dest fp l'+createFpAndTrim maxLen action = assert (maxLen >= 0) $ do+ fp <- mallocByteString maxLen+ len <- action fp+ if assert (0 <= len && len <= maxLen) $ len >= maxLen+ then mkDeferredByteString fp maxLen+ else createFp len $ \dest -> memcpyFp dest fp len {-# INLINE createFpAndTrim #-} createFpAndTrim' :: Int -> (ForeignPtr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a)-createFpAndTrim' l action = do- fp <- mallocByteString l- (off, l', res) <- action fp- bs <- if assert (0 <= l' && l' <= l) $ l' >= l- then mkDeferredByteString fp l -- entire buffer used => offset is zero- else createFp l' $ \dest ->- memcpyFp dest (fp `plusForeignPtr` off) l'+createFpAndTrim' maxLen action = assert (maxLen >= 0) $ do+ fp <- mallocByteString maxLen+ (off, len, res) <- action fp+ assert (+ 0 <= len && len <= maxLen && -- length OK+ (len == 0 || (0 <= off && off <= maxLen - len)) -- offset OK+ ) $ pure ()+ bs <- if len >= maxLen+ then mkDeferredByteString fp maxLen -- entire buffer used => offset is zero+ else createFp len $ \dest ->+ memcpyFp dest (fp `plusForeignPtr` off) len return (bs, res) {-# INLINE createFpAndTrim' #-} @@ -791,7 +811,7 @@ append (BS _ 0) b = b append a (BS _ 0) = a append (BS fp1 len1) (BS fp2 len2) =- unsafeCreateFp (len1+len2) $ \destptr1 -> do+ unsafeCreateFp (checkedAdd "append" len1 len2) $ \destptr1 -> do let destptr2 = destptr1 `plusForeignPtr` len1 memcpyFp destptr1 fp1 len1 memcpyFp destptr2 fp2 len2@@ -847,37 +867,57 @@ concat [x] = x #-} --- | /O(log n)/ Repeats the given ByteString n times.-times :: Integral a => a -> ByteString -> ByteString-times n (BS fp len)- | n < 0 = error "stimes: non-negative multiplier expected"+-- | Repeats the given ByteString n times.+-- Polymorphic wrapper to make sure any generated+-- specializations are reasonably small.+stimesPolymorphic :: Integral a => a -> ByteString -> ByteString+{-# INLINABLE stimesPolymorphic #-}+stimesPolymorphic nRaw !bs = case checkedIntegerToInt n of+ Just nInt+ | nInt >= 0 -> stimesNonNegativeInt nInt bs+ | otherwise -> stimesNegativeErr+ Nothing+ | n < 0 -> stimesNegativeErr+ | BS _ 0 <- bs -> empty+ | otherwise -> stimesOverflowErr+ where n = toInteger nRaw+ -- By exclusively using n instead of nRaw, the semantics are kept simple+ -- and the likelihood of potentially dangerous mistakes minimized.+++stimesNegativeErr :: ByteString+stimesNegativeErr+ = error "stimes @ByteString: non-negative multiplier expected"++stimesOverflowErr :: ByteString+-- Although this only appears once, it is extracted here to prevent it+-- from being duplicated in specializations of 'stimesPolymorphic'+stimesOverflowErr = overflowError "stimes"++-- | Repeats the given ByteString n times.+stimesNonNegativeInt :: Int -> ByteString -> ByteString+stimesNonNegativeInt n (BS fp len) | n == 0 = empty | n == 1 = BS fp len | len == 0 = empty- | len == 1 = unsafeCreateFp size $ \destfptr -> do+ | len == 1 = unsafeCreateFp n $ \destfptr -> do byte <- peekFp fp unsafeWithForeignPtr destfptr $ \destptr ->- fillBytes destptr byte (fromIntegral n)+ fillBytes destptr byte n | otherwise = unsafeCreateFp size $ \destptr -> do memcpyFp destptr fp len fillFrom destptr len where- size = len * fromIntegral n+ size = checkedMultiply "stimes" n len+ halfSize = (size - 1) `div` 2 -- subtraction and division won't overflow fillFrom :: ForeignPtr Word8 -> Int -> IO () fillFrom destptr copied- | 2 * copied <= size = do+ | copied <= halfSize = do memcpyFp (destptr `plusForeignPtr` copied) destptr copied fillFrom destptr (copied * 2) | otherwise = memcpyFp (destptr `plusForeignPtr` copied) destptr (size - copied) --- | Add two non-negative numbers. Errors out on overflow. ...-checkedAdd :: String -> Int -> Int -> Int-checkedAdd fun x y- | r >= 0 = r- | otherwise = overflowError fun- where r = x + y-{-# INLINE checkedAdd #-} ------------------------------------------------------------------------ @@ -912,8 +952,66 @@ isSpaceChar8 = isSpaceWord8 . c2w {-# INLINE isSpaceChar8 #-} +------------------------------------------------------------------------++-- | The type of exception raised by 'overflowError'+-- and on failure by overflow-checked arithmetic operations.+newtype SizeOverflowException+ = SizeOverflowException String++instance Show SizeOverflowException where+ show (SizeOverflowException err) = err++instance Exception SizeOverflowException++-- | Raises a 'SizeOverflowException',+-- with a message using the given function name. overflowError :: String -> a-overflowError fun = error $ "Data.ByteString." ++ fun ++ ": size overflow"+overflowError fun = throw $ SizeOverflowException msg+ where msg = "Data.ByteString." ++ fun ++ ": size overflow"++-- | Add two non-negative numbers.+-- Calls 'overflowError' on overflow.+checkedAdd :: String -> Int -> Int -> Int+{-# INLINE checkedAdd #-}+checkedAdd fun x y+ -- checking "r < 0" here matches the condition in mallocPlainForeignPtrBytes,+ -- helping the compiler see the latter is redundant in some places+ | r < 0 = overflowError fun+ | otherwise = r+ where r = assert (min x y >= 0) $ x + y++-- | Multiplies two non-negative numbers.+-- Calls 'overflowError' on overflow.+checkedMultiply :: String -> Int -> Int -> Int+{-# INLINE checkedMultiply #-}+checkedMultiply fun !x@(I# x#) !y@(I# y#) = assert (min x y >= 0) $+#if TIMES_INT_2_AVAILABLE+ case timesInt2# x# y# of+ (# 0#, _, result #) -> I# result+ _ -> overflowError fun+#else+ case timesWord2# (int2Word# x#) (int2Word# y#) of+ (# hi, lo #) -> case or# hi (uncheckedShiftRL# lo shiftAmt) of+ 0## -> I# (word2Int# lo)+ _ -> overflowError fun+ where !(I# shiftAmt) = finiteBitSize (0 :: Word) - 1+#endif+++-- | Attempts to convert an 'Integer' value to an 'Int', returning+-- 'Nothing' if doing so would result in an overflow.+checkedIntegerToInt :: Integer -> Maybe Int+{-# INLINE checkedIntegerToInt #-}+-- We could use Data.Bits.toIntegralSized, but this hand-rolled+-- version is currently a bit faster as of GHC 9.2.+-- It's even faster to just match on the Integer constructors, but+-- we'd still need a fallback implementation for integer-simple.+checkedIntegerToInt x+ | x == toInteger res = Just res+ | otherwise = Nothing+ where res = fromInteger x :: Int+ ------------------------------------------------------------------------
Data/ByteString/Lazy/Char8.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-}-{-# OPTIONS_HADDOCK prune #-} {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_HADDOCK prune #-} -- | -- Module : Data.ByteString.Lazy.Char8@@ -179,8 +180,28 @@ copy, -- * Reading from ByteStrings+ -- | Note that a lazy 'ByteString' may hold an unbounded stream of+ -- @\'0\'@ digits, in which case the functions below may never return.+ -- If that's a concern, you can use 'take' to first truncate the input+ -- to an acceptable length. Non-termination is also possible when+ -- reading arbitrary precision numbers via 'readInteger' or+ -- 'readNatural', if the input is an unbounded stream of arbitrary+ -- decimal digits.+ -- readInt,+ readInt64,+ readInt32,+ readInt16,+ readInt8,++ readWord,+ readWord64,+ readWord32,+ readWord16,+ readWord8,+ readInteger,+ readNatural, -- * I\/O with 'ByteString's -- | ByteString I/O uses binary mode, without any character decoding@@ -228,8 +249,10 @@ import qualified Data.ByteString.Unsafe as B import Data.List.NonEmpty (NonEmpty(..)) import Data.ByteString.Lazy.Internal+import Data.ByteString.Lazy.ReadInt+import Data.ByteString.Lazy.ReadNat -import Data.ByteString.Internal (w2c, c2w, isSpaceWord8)+import Data.ByteString.Internal (c2w,w2c,isSpaceWord8) import Data.Int (Int64) import qualified Data.List as List@@ -899,96 +922,6 @@ unwords :: [ByteString] -> ByteString unwords = intercalate (singleton ' ') {-# INLINE unwords #-}---- | readInt reads an Int from the beginning of the ByteString. If--- there is no integer at the beginning of the string, it returns--- Nothing, otherwise it just returns the int read, and the rest of the--- string.------ Note: This function will overflow the Int for large integers.--readInt :: ByteString -> Maybe (Int, ByteString)-{-# INLINE readInt #-}-readInt Empty = Nothing-readInt (Chunk x xs) = case w2c (B.unsafeHead x) of- '-' -> loop True 0 0 (B.unsafeTail x) xs- '+' -> loop False 0 0 (B.unsafeTail x) xs- _ -> loop False 0 0 x xs-- where loop :: Bool -> Int -> Int- -> S.ByteString -> ByteString -> Maybe (Int, ByteString)- loop neg !i !n !c cs- | B.null c = case cs of- Empty -> end neg i n c cs- (Chunk c' cs') -> loop neg i n c' cs'- | otherwise =- case B.unsafeHead c of- w | w >= 0x30- && w <= 0x39 -> loop neg (i+1)- (n * 10 + (fromIntegral w - 0x30))- (B.unsafeTail c) cs- | otherwise -> end neg i n c cs-- {-# INLINE end #-}- end _ 0 _ _ _ = Nothing- end neg _ n c cs = e- where n' = if neg then negate n else n- c' = chunk c cs- e = n' `seq` c' `seq` Just (n',c')- -- in n' `seq` c' `seq` JustS n' c'---- | readInteger reads an Integer from the beginning of the ByteString. If--- there is no integer at the beginning of the string, it returns Nothing,--- otherwise it just returns the int read, and the rest of the string.-readInteger :: ByteString -> Maybe (Integer, ByteString)-readInteger Empty = Nothing-readInteger (Chunk c0 cs0) =- case w2c (B.unsafeHead c0) of- '-' -> first (B.unsafeTail c0) cs0 >>= \(n, cs') -> return (-n, cs')- '+' -> first (B.unsafeTail c0) cs0- _ -> first c0 cs0-- where first c cs- | B.null c = case cs of- Empty -> Nothing- (Chunk c' cs') -> first' c' cs'- | otherwise = first' c cs-- first' c cs = case B.unsafeHead c of- w | w >= 0x30 && w <= 0x39 -> Just $- loop 1 (fromIntegral w - 0x30) [] (B.unsafeTail c) cs- | otherwise -> Nothing-- loop :: Int -> Int -> [Integer]- -> S.ByteString -> ByteString -> (Integer, ByteString)- loop !d !acc ns !c cs- | B.null c = case cs of- Empty -> combine d acc ns c cs- (Chunk c' cs') -> loop d acc ns c' cs'- | otherwise =- case B.unsafeHead c of- w | w >= 0x30 && w <= 0x39 ->- if d < 9 then loop (d+1)- (10*acc + (fromIntegral w - 0x30))- ns (B.unsafeTail c) cs- else loop 1 (fromIntegral w - 0x30)- (fromIntegral acc : ns)- (B.unsafeTail c) cs- | otherwise -> combine d acc ns c cs-- combine _ acc [] c cs = end (fromIntegral acc) c cs- combine d acc ns c cs =- end (10^d * combine1 1000000000 ns + fromIntegral acc) c cs-- combine1 _ [n] = n- combine1 b ns = combine1 (b*b) $ combine2 b ns-- combine2 b (n:m:ns) = let !t = n+m*b in t : combine2 b ns- combine2 _ ns = ns-- end n c cs = let !c' = chunk c cs- in (n, c')- -- | Write a ByteString to a handle, appending a newline byte. --
Data/ByteString/Lazy/Internal.hs view
@@ -337,11 +337,11 @@ -- It's still possible that the result is a single chunk goLen1 _ bs Empty = bs goLen1 cs0 (S.BS _ bl) (Chunk (S.BS _ cl) cs) =- goLen cs0 (S.checkedAdd "Lazy.concat" bl cl) cs+ goLen cs0 (S.checkedAdd "Lazy.toStrict" bl cl) cs -- General case, just find the total length we'll need goLen cs0 !total (Chunk (S.BS _ cl) cs) =- goLen cs0 (S.checkedAdd "Lazy.concat" total cl) cs+ goLen cs0 (S.checkedAdd "Lazy.toStrict" total cl) cs goLen cs0 total Empty = S.unsafeCreateFp total $ \ptr -> goCopy cs0 ptr
+ Data/ByteString/Lazy/ReadInt.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- This file is also included by "Data.ByteString.ReadInt", after defining+-- "BYTESTRING_STRICT". The two modules share much of their code, but+-- the lazy version adds an outer loop over the chunks.++#ifdef BYTESTRING_STRICT+module Data.ByteString.ReadInt+#else+module Data.ByteString.Lazy.ReadInt+#endif+ ( readInt+ , readInt8+ , readInt16+ , readInt32+ , readWord+ , readWord8+ , readWord16+ , readWord32+ , readInt64+ , readWord64+ ) where++import qualified Data.ByteString.Internal as BI+#ifdef BYTESTRING_STRICT+import Data.ByteString+#else+import Data.ByteString.Lazy+import Data.ByteString.Lazy.Internal+#endif+import Data.Bits (FiniteBits, isSigned)+import Data.ByteString.Internal (pattern BS, plusForeignPtr)+import Data.Int+import Data.Word+import Foreign.ForeignPtr (ForeignPtr)+import Foreign.Ptr (minusPtr, plusPtr)+import Foreign.Storable (Storable(..))++----- Public API++-- | Try to read a signed 'Int' value from the 'ByteString', returning+-- @Just (val, str)@ on success, where @val@ is the value read and @str@ is the+-- rest of the input string. If the sequence of digits decodes to a value+-- larger than can be represented by an 'Int', the returned value will be+-- 'Nothing'.+--+-- 'readInt' does not ignore leading whitespace, the value must start+-- immediately at the beginning of the input string.+--+-- ==== __Examples__+-- >>> readInt "-1729 sum of cubes"+-- Just (-1729," sum of cubes")+-- >>> readInt "+1: readInt also accepts a leading '+'"+-- Just (1, ": readInt also accepts a leading '+'")+-- >>> readInt "not a decimal number"+-- Nothing+-- >>> readInt "12345678901234567890 overflows maxBound"+-- Nothing+-- >>> readInt "-12345678901234567890 underflows minBound"+-- Nothing+--+readInt :: ByteString -> Maybe (Int, ByteString)+readInt = _read++-- | A variant of 'readInt' specialised to 'Int32'.+readInt32 :: ByteString -> Maybe (Int32, ByteString)+readInt32 = _read++-- | A variant of 'readInt' specialised to 'Int16'.+readInt16 :: ByteString -> Maybe (Int16, ByteString)+readInt16 = _read++-- | A variant of 'readInt' specialised to 'Int8'.+readInt8 :: ByteString -> Maybe (Int8, ByteString)+readInt8 = _read++-- | Try to read a 'Word' value from the 'ByteString', returning+-- @Just (val, str)@ on success, where @val@ is the value read and @str@ is the+-- rest of the input string. If the sequence of digits decodes to a value+-- larger than can be represented by a 'Word', the returned value will be+-- 'Nothing'.+--+-- 'readWord' does not ignore leading whitespace, the value must start with a+-- decimal digit immediately at the beginning of the input string. Leading @+@+-- signs are not accepted.+--+-- ==== __Examples__+-- >>> readWord "1729 sum of cubes"+-- Just (1729," sum of cubes")+-- >>> readWord "+1729 has an explicit sign"+-- Nothing+-- >>> readWord "not a decimal number"+-- Nothing+-- >>> readWord "98765432109876543210 overflows maxBound"+-- Nothing+--+readWord :: ByteString -> Maybe (Word, ByteString)+readWord = _read++-- | A variant of 'readWord' specialised to 'Word32'.+readWord32 :: ByteString -> Maybe (Word32, ByteString)+readWord32 = _read++-- | A variant of 'readWord' specialised to 'Word16'.+readWord16 :: ByteString -> Maybe (Word16, ByteString)+readWord16 = _read++-- | A variant of 'readWord' specialised to 'Word8'.+readWord8 :: ByteString -> Maybe (Word8, ByteString)+readWord8 = _read++-- | A variant of 'readInt' specialised to 'Int64'.+readInt64 :: ByteString -> Maybe (Int64, ByteString)+readInt64 = _read++-- | A variant of 'readWord' specialised to 'Word64'.+readWord64 :: ByteString -> Maybe (Word64, ByteString)+readWord64 = _read++-- | Polymorphic Int*/Word* reader+_read :: forall a. (Integral a, FiniteBits a, Bounded a)+ => ByteString -> Maybe (a, ByteString)+{-# INLINE _read #-}+_read+ | isSigned @a 0+ = \ bs -> signed bs >>= \ (r, s, d1) -> _readDecimal r s d1+ | otherwise+ -- When the input is @16^n-1@, as is the case with 'maxBound' for+ -- all the Word* types, the last decimal digit of 'maxBound' is 5.+ = \ bs -> unsigned 5 bs >>= \ (r, s, d1) -> _readDecimal r s d1+ where+ -- Returns:+ -- * Mod 10 min/max bound remainder+ -- * 2nd and later digits+ -- * 1st digit+ --+ -- When the input is @8*16^n-1@, as is the case with 'maxBound' for+ -- all the Int* types, the last decimal digit of 'maxBound' is 7.+ --+ signed :: ByteString -> Maybe (Word64, ByteString, Word64)+ signed bs = do+ (w, s) <- uncons bs+ let d1 = fromDigit w+ if | d1 <= 9 -> Just (7, s, d1) -- leading digit+ | w == 0x2d -> unsigned 8 s -- minus sign+ | w == 0x2b -> unsigned 7 s -- plus sign+ | otherwise -> Nothing -- not a number++ unsigned :: Word64 -> ByteString -> Maybe (Word64, ByteString, Word64)+ unsigned r bs = do+ (w, s) <- uncons bs+ let d1 = fromDigit w+ if | d1 <= 9 -> Just (r, s, d1) -- leading digit+ | otherwise -> Nothing -- not a number++----- Fixed-width unsigned reader++-- | Intermediate result from scanning a chunk, final output is+-- converted to the requested type once all chunks are processed.+--+data Result = Overflow+ | Result !Int -- number of bytes (digits) read+ !Word64 -- accumulator value++_readDecimal :: forall a. (Integral a, Bounded a)+ => Word64 -- ^ abs(maxBound/minBound) `mod` 10+ -> ByteString -- ^ Input string+ -> Word64 -- ^ First digit value+ -> Maybe (a, ByteString)+{-# INLINE _readDecimal #-}+_readDecimal !r = consume+ where+ consume :: ByteString -> Word64 -> Maybe (a, ByteString)+#ifdef BYTESTRING_STRICT+ consume (BS fp len) a = case _digits q r fp len a of+ Result used acc+ | used == len+ -> convert acc empty+ | otherwise+ -> convert acc $ BS (fp `plusForeignPtr` used) (len - used)+ _ -> Nothing+#else+ -- All done+ consume Empty acc = convert acc Empty+ -- Process next chunk+ consume (Chunk (BS fp len) cs) acc+ = case _digits q r fp len acc of+ Result used acc'+ | used == len+ -- process remaining chunks+ -> consume cs acc'+ | otherwise+ -- ran into a non-digit+ -> convert acc' $+ Chunk (BS (fp `plusForeignPtr` used) (len - used)) cs+ _ -> Nothing+#endif+ convert :: Word64 -> ByteString -> Maybe (a, ByteString)+ convert !acc rest =+ let !i = case r of+ -- minBound @Int* `mod` 10 == 8+ 8 -> negate $ fromIntegral @Word64 @a acc+ _ -> fromIntegral @Word64 @a acc+ in Just (i, rest)++ -- The quotient of 'maxBound' divided by 10 is needed for+ -- overflow checks, once the accumulator exceeds this value+ -- no further digits can be added. If equal, the last digit+ -- must not exceed the `r` value (max/min bound `mod` 10).+ --+ q = fromIntegral @a @Word64 maxBound `div` 10++----- Per chunk decoder++-- | Process as many digits as we can, returning the additional+-- number of digits found and the updated accumulator. If the+-- accumulator would overflow return 'Overflow'.+--+_digits :: Word64 -- ^ maximum non-overflow value `div` 10+ -> Word64 -- ^ maximum non-overflow vavlue `mod` 10+ -> ForeignPtr Word8 -- ^ Input buffer+ -> Int -- ^ Input length+ -> Word64 -- ^ Accumulated value of leading digits+ -> Result -- ^ Bytes read and final accumulator,+ -- or else overflow indication+{-# INLINE _digits #-}+_digits !q !r fp len a = BI.accursedUnutterablePerformIO $+ BI.unsafeWithForeignPtr fp $ \ ptr -> do+ let end = ptr `plusPtr` len+ go ptr end ptr a+ where+ go !start !end = loop+ where+ loop !ptr !acc = getDigit >>= \ !d ->+ if | d > 9+ -> return $ Result (ptr `minusPtr` start) acc+ | acc < q || acc == q && d <= r+ -> loop (ptr `plusPtr` 1) (acc * 10 + d)+ | otherwise+ -> return Overflow+ where+ getDigit :: IO Word64+ getDigit+ | ptr /= end = fromDigit <$> peek ptr+ | otherwise = pure 10 -- End of input+ {-# NOINLINE getDigit #-}+ -- 'getDigit' makes it possible to implement a single success+ -- exit point from the loop. If instead we return 'Result'+ -- from multiple places, when '_digits' is inlined we get (at+ -- least GHC 8.10 through 9.2) for each exit path a separate+ -- join point implementing the continuation code. GHC ticket+ -- <https://gitlab.haskell.org/ghc/ghc/-/issues/20739>.+ --+ -- The NOINLINE pragma is required to avoid inlining branches+ -- that would restore multiple exit points.++fromDigit :: Word8 -> Word64+{-# INLINE fromDigit #-}+fromDigit = \ !w -> fromIntegral w - 0x30 -- i.e. w - '0'
+ Data/ByteString/Lazy/ReadNat.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- This file is included by "Data.ByteString.ReadInt", after defining+-- "BYTESTRING_STRICT". The two modules are largely identical, except for the+-- choice of ByteString type and the loops in `readNatural`, where the lazy+-- version needs to nest the inner loop inside a loop over the constituent+-- chunks.++#ifdef BYTESTRING_STRICT+module Data.ByteString.ReadNat+#else+module Data.ByteString.Lazy.ReadNat+#endif+ ( readInteger+ , readNatural+ ) where++import qualified Data.ByteString.Internal as BI+#ifdef BYTESTRING_STRICT+import Data.ByteString+#else+import Data.ByteString.Lazy+import Data.ByteString.Lazy.Internal+#endif+import Data.Bits (finiteBitSize)+import Data.ByteString.Internal (pattern BS, plusForeignPtr)+import Data.Word+import Foreign.ForeignPtr (ForeignPtr)+import Foreign.Ptr (Ptr, minusPtr, plusPtr)+import Foreign.Storable (Storable(..))+import Numeric.Natural (Natural)++----- Public API++-- | 'readInteger' reads an 'Integer' from the beginning of the 'ByteString'.+-- If there is no 'Integer' at the beginning of the string, it returns+-- 'Nothing', otherwise it just returns the 'Integer' read, and the rest of+-- the string.+--+-- 'readInteger' does not ignore leading whitespace, the value must start+-- immediately at the beginning of the input string.+--+-- ==== __Examples__+-- >>> readInteger "-000111222333444555666777888999 all done"+-- Just (-111222333444555666777888999," all done")+-- >>> readInteger "+1: readInteger also accepts a leading '+'"+-- Just (1, ": readInteger also accepts a leading '+'")+-- >>> readInteger "not a decimal number"+-- Nothing+--+readInteger :: ByteString -> Maybe (Integer, ByteString)+readInteger = \ bs -> do+ (w, s) <- uncons bs+ let d = fromDigit w+ if | d <= 9 -> unsigned d s -- leading digit+ | w == 0x2d -> negative s -- minus sign+ | w == 0x2b -> positive s -- plus sign+ | otherwise -> Nothing -- not a number+ where+ unsigned :: Word -> ByteString -> Maybe (Integer, ByteString)+ unsigned d s =+ let (!n, rest) = _readDecimal d s+ !i = toInteger n+ in Just (i, rest)++ positive :: ByteString -> Maybe (Integer, ByteString)+ positive bs = do+ (w, s) <- uncons bs+ let d = fromDigit w+ if | d <= 9 -> unsigned d s+ | otherwise -> Nothing++ negative :: ByteString -> Maybe (Integer, ByteString)+ negative bs = do+ (w, s) <- uncons bs+ let d = fromDigit w+ if | d > 9 -> Nothing+ | otherwise -> let (n, rest) = _readDecimal d s+ !i = negate $ toInteger n+ in Just (i, rest)++-- | 'readNatural' reads a 'Natural' number from the beginning of the+-- 'ByteString'. If there is no 'Natural' number at the beginning of the+-- string, it returns 'Nothing', otherwise it just returns the number read, and+-- the rest of the string.+--+-- 'readNatural' does not ignore leading whitespace, the value must start with+-- a decimal digit immediately at the beginning of the input string. Leading+-- @+@ signs are not accepted.+--+-- ==== __Examples__+-- >>> readNatural "000111222333444555666777888999 all done"+-- Just (111222333444555666777888999," all done")+-- >>> readNatural "+000111222333444555666777888999 explicit sign"+-- Nothing+-- >>> readNatural "not a decimal number"+-- Nothing+--+readNatural :: ByteString -> Maybe (Natural, ByteString)+readNatural bs = do+ (w, s) <- uncons bs+ let d = fromDigit w+ if | d <= 9 -> Just $! _readDecimal d s+ | otherwise -> Nothing++----- Internal implementation++-- | Intermediate result from scanning a chunk, final output is+-- obtained via `convert` after all the chunks are processed.+--+data Result = Result !Int -- Bytes consumed+ !Word -- Value of LSW+ !Int -- Digits in LSW+ [Natural] -- Little endian MSW list++_readDecimal :: Word -> ByteString -> (Natural, ByteString)+_readDecimal =+ -- Having read one digit, we're about to read the 2nd So the digit count+ -- up to 'safeLog' starts at 2.+ consume [] 2+ where+ consume :: [Natural] -> Int -> Word -> ByteString+ -> (Natural, ByteString)+#ifdef BYTESTRING_STRICT+ consume ns cnt acc (BS fp len) =+ -- Having read one digit, we're about to read the 2nd+ -- So the digit count up to 'safeLog' starts at 2.+ case natdigits fp len acc cnt ns of+ Result used acc' cnt' ns'+ | used == len+ -> convert acc' cnt' ns' $ empty+ | otherwise+ -> convert acc' cnt' ns' $+ BS (fp `plusForeignPtr` used) (len - used)+#else+ -- All done+ consume ns cnt acc Empty = convert acc cnt ns Empty+ -- Process next chunk+ consume ns cnt acc (Chunk (BS fp len) cs)+ = case natdigits fp len acc cnt ns of+ Result used acc' cnt' ns'+ | used == len -- process more chunks+ -> consume ns' cnt' acc' cs+ | otherwise -- ran into a non-digit+ -> let c = Chunk (BS (fp `plusForeignPtr` used) (len - used)) cs+ in convert acc' cnt' ns' c+#endif+ convert !acc !cnt !ns rest =+ let !n = combine acc cnt ns+ in (n, rest)++ -- | Merge least-significant word with reduction of of little-endian tail.+ --+ -- The input is:+ --+ -- * Least significant digits as a 'Word' (LSW)+ -- * The number of digits that went into the LSW+ -- * All the remaining digit groups ('safeLog' digits each),+ -- in little-endian order+ --+ -- The result is obtained by pairwise recursive combining of all the+ -- full size digit groups, followed by multiplication by @10^cnt@ and+ -- addition of the LSW.+ combine :: Word -- ^ value of LSW+ -> Int -- ^ count of digits in LSW+ -> [Natural] -- ^ tail elements (base @10^'safeLog'@)+ -> Natural+ {-# INLINE combine #-}+ combine !acc !_ [] = wordToNatural acc+ combine !acc !cnt ns =+ wordToNatural (10^cnt) * combine1 safeBase ns + wordToNatural acc++ -- | Recursive reduction of little-endian sequence of 'Natural'-valued+ -- /digits/ in base @base@ (a power of 10). The base is squared after+ -- each round. This shows better asymptotic performance than one word+ -- at a time multiply-add folds. See:+ -- <https://gmplib.org/manual/Multiplication-Algorithms>+ --+ combine1 :: Natural -> [Natural] -> Natural+ combine1 _ [n] = n+ combine1 base ns = combine1 (base * base) (combine2 base ns)++ -- | One round pairwise merge of numbers in base @base@.+ combine2 :: Natural -> [Natural] -> [Natural]+ combine2 base (n:m:ns) = let !t = m * base + n in t : combine2 base ns+ combine2 _ ns = ns++-- The intermediate representation is a little-endian sequence in base+-- @10^'safeLog'@, prefixed by an initial element in base @10^cnt@ for some+-- @cnt@ between 1 and 'safeLog'. The final result is obtained by recursive+-- pairwise merging of the tail followed by a final multiplication by @10^cnt@+-- and addition of the head.+--+natdigits :: ForeignPtr Word8 -- ^ Input chunk+ -> Int -- ^ Chunk length+ -> Word -- ^ accumulated element+ -> Int -- ^ partial digit count+ -> [Natural] -- ^ accumulated MSB elements+ -> Result+{-# INLINE natdigits #-}+natdigits fp len = \ acc cnt ns ->+ BI.accursedUnutterablePerformIO $+ BI.unsafeWithForeignPtr fp $ \ ptr -> do+ let end = ptr `plusPtr` len+ go ptr end acc cnt ns ptr+ where+ go !start !end = loop+ where+ loop :: Word -> Int -> [Natural] -> Ptr Word8 -> IO Result+ loop !acc !cnt ns !ptr = getDigit >>= \ !d ->+ if | d > 9+ -> return $ Result (ptr `minusPtr` start) acc cnt ns+ | cnt < safeLog+ -> loop (10*acc + d) (cnt+1) ns $ ptr `plusPtr` 1+ | otherwise+ -> let !acc' = wordToNatural acc+ in loop d 1 (acc' : ns) $ ptr `plusPtr` 1+ where+ getDigit | ptr /= end = fromDigit <$> peek ptr+ | otherwise = pure 10 -- End of input+ {-# NOINLINE getDigit #-}+ -- 'getDigit' makes it possible to implement a single success+ -- exit point from the loop. If instead we return 'Result'+ -- from multiple places, when 'natdigits' is inlined we get (at+ -- least GHC 8.10 through 9.2) for each exit path a separate+ -- join point implementing the continuation code. GHC ticket+ -- <https://gitlab.haskell.org/ghc/ghc/-/issues/20739>.+ --+ -- The NOINLINE pragma is required to avoid inlining branches+ -- that would restore multiple exit points.++----- Misc functions++-- | Largest decimal digit count that never overflows the accumulator+-- The base 10 logarithm of 2 is ~0.30103, therefore 2^n has at least+-- @1 + floor (0.3 n)@ decimal digits. Therefore @floor (0.3 n)@,+-- digits cannot overflow the upper bound of an @n-bit@ word.+--+safeLog :: Int+safeLog = 3 * finiteBitSize @Word 0 `div` 10++-- | 10-power base for little-endian sequence of ~Word-sized "digits"+safeBase :: Natural+safeBase = 10 ^ safeLog++fromDigit :: Word8 -> Word+{-# INLINE fromDigit #-}+fromDigit = \ !w -> fromIntegral w - 0x30 -- i.e. w - '0'++wordToNatural :: Word -> Natural+{-# INLINE wordToNatural #-}+wordToNatural = fromIntegral
+ Data/ByteString/ReadInt.hs view
@@ -0,0 +1,3 @@+{-# LANGUAGE CPP #-}+#define BYTESTRING_STRICT+#include "Lazy/ReadInt.hs"
+ Data/ByteString/ReadNat.hs view
@@ -0,0 +1,3 @@+{-# LANGUAGE CPP #-}+#define BYTESTRING_STRICT+#include "Lazy/ReadNat.hs"
Data/ByteString/Short/Internal.hs view
@@ -1,10 +1,13 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveLift #-} {-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskellQuotes #-}@@ -42,7 +45,7 @@ module Data.ByteString.Short.Internal ( -- * The @ShortByteString@ type and representation- ShortByteString(..),+ ShortByteString(.., SBS), -- * Introducing and eliminating 'ShortByteString's empty,@@ -165,6 +168,8 @@ , checkedAdd ) +import Data.Array.Byte+ ( ByteArray(..) ) import Data.Bits ( FiniteBits (finiteBitSize) , shiftL@@ -175,21 +180,17 @@ , (.|.) ) import Data.Data- ( Data(..)- , mkNoRepType- )+ ( Data(..) ) import Data.Monoid ( Monoid(..) ) import Data.Semigroup ( Semigroup((<>)) ) import Data.String ( IsString(..) )-import Data.Typeable- ( Typeable ) import Control.Applicative ( pure ) import Control.DeepSeq- ( NFData(..) )+ ( NFData ) import Control.Exception ( assert ) import Control.Monad@@ -272,7 +273,6 @@ import qualified Data.List as List import qualified GHC.Exts-import qualified Language.Haskell.TH.Lib as TH import qualified Language.Haskell.TH.Syntax as TH -- | A compact representation of a 'Word8' vector.@@ -282,43 +282,35 @@ -- 'ByteString' (at the cost of copying the string data). It supports very few -- other operations. ---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+newtype ShortByteString =+ -- | @since 0.12.0.0+ ShortByteString+ { unShortByteString :: ByteArray+ -- ^ @since 0.12.0.0+ }+ deriving (Eq, TH.Lift, Data, NFData) -#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+-- | Prior to @bytestring-0.12@ 'SBS' was a genuine constructor of 'ShortByteString',+-- but now it is a bundled pattern synonym, provided as a compatibility shim.+pattern SBS :: ByteArray# -> ShortByteString+pattern SBS x = ShortByteString (ByteArray x)+#if __GLASGOW_HASKELL__ >= 802+{-# COMPLETE SBS #-}+-- To avoid spurious warnings from CI with ghc-8.0, we internally+-- use view patterns like (unSBS -> ba#) instead of using (SBS ba#) #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,--- but we have to be careful with reads, see equateBytes and compareBytes below.---instance Eq ShortByteString where- (==) = equateBytes-+-- | Lexicographic order. instance Ord ShortByteString where compare = compareBytes +-- Instead of deriving Semigroup / Monoid , we stick to our own implementations+-- of mappend / mconcat, because they are safer with regards to overflows+-- (see prop_32bitOverflow_Short_mconcat test).+-- ByteArray is likely to catch up starting from GHC 9.6:+-- * https://gitlab.haskell.org/ghc/ghc/-/merge_requests/8272+-- * https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9128+ instance Semigroup ShortByteString where (<>) = append @@ -327,9 +319,6 @@ mappend = (<>) mconcat = concat -instance NFData ShortByteString where- rnf SBS{} = ()- instance Show ShortByteString where showsPrec p ps r = showsPrec p (unpackChars ps) r @@ -339,20 +328,15 @@ -- | @since 0.10.12.0 instance GHC.Exts.IsList ShortByteString where type Item ShortByteString = Word8- fromList = packBytes- toList = unpack+ fromList = ShortByteString . GHC.Exts.fromList+ fromListN = (ShortByteString .) . GHC.Exts.fromListN+ toList = GHC.Exts.toList . unShortByteString -- | Beware: 'fromString' truncates multi-byte characters to octets. -- e.g. "枯朶に烏のとまりけり秋の暮" becomes �6k�nh~�Q��n� instance IsString ShortByteString where fromString = packChars -instance Data ShortByteString where- gfoldl f z txt = z packBytes `f` unpack txt- toConstr _ = error "Data.ByteString.Short.ShortByteString.toConstr"- gunfold _ _ = error "Data.ByteString.Short.ShortByteString.gunfold"- dataTypeOf _ = mkNoRepType "Data.ByteString.Short.ShortByteString"- ------------------------------------------------------------------------ -- Simple operations @@ -405,12 +389,6 @@ moduleError "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# =- -- createFromPtr allocates, so accursedUnutterablePerformIO is wrong- unsafeDupablePerformIO $ createFromPtr (Ptr addr#) len- ------------------------------------------------------------------------ -- Internal utils @@ -418,11 +396,11 @@ asBA (unSBS -> ba#) = BA# ba# unSBS :: ShortByteString -> ByteArray#-unSBS (SBS ba#) = ba#+unSBS (ShortByteString (ByteArray ba#)) = ba# create :: Int -> (forall s. MBA s -> ST s ()) -> ShortByteString create len fill =- runST $ do+ assert (len >= 0) $ runST $ do mba <- newByteArray len fill mba BA# ba# <- unsafeFreezeByteArray mba@@ -435,59 +413,60 @@ -- (<= the maximum size) and the result value. The resulting byte array -- is realloced to this size. createAndTrim :: Int -> (forall s. MBA s -> ST s (Int, a)) -> (ShortByteString, a)-createAndTrim l fill =- runST $ do- mba <- newByteArray l- (l', res) <- fill mba- if assert (l' <= l) $ l' >= l+createAndTrim maxLen fill =+ assert (maxLen >= 0) $ runST $ do+ mba <- newByteArray maxLen+ (len, res) <- fill mba+ if assert (0 <= len && len <= maxLen) $ len >= maxLen then do BA# ba# <- unsafeFreezeByteArray mba return (SBS ba#, res) else do- mba2 <- newByteArray l'- copyMutableByteArray mba 0 mba2 0 l'+ mba2 <- newByteArray len+ copyMutableByteArray mba 0 mba2 0 len BA# ba# <- unsafeFreezeByteArray mba2 return (SBS ba#, res) {-# INLINE createAndTrim #-} createAndTrim' :: Int -> (forall s. MBA s -> ST s Int) -> ShortByteString-createAndTrim' l fill =- runST $ do- mba <- newByteArray l- l' <- fill mba- if assert (l' <= l) $ l' >= l+createAndTrim' maxLen fill =+ assert (maxLen >= 0) $ runST $ do+ mba <- newByteArray maxLen+ len <- fill mba+ if assert (0 <= len && len <= maxLen) $ len >= maxLen then do BA# ba# <- unsafeFreezeByteArray mba return (SBS ba#) else do- mba2 <- newByteArray l'- copyMutableByteArray mba 0 mba2 0 l'+ mba2 <- newByteArray len+ copyMutableByteArray mba 0 mba2 0 len BA# ba# <- unsafeFreezeByteArray mba2 return (SBS ba#) {-# INLINE createAndTrim' #-} -createAndTrim'' :: Int -> (forall s. MBA s -> MBA s -> ST s (Int, Int)) -> (ShortByteString, ShortByteString)-createAndTrim'' l fill =+-- | Like createAndTrim, but with two buffers at once+createAndTrim2 :: Int -> Int -> (forall s. MBA s -> MBA s -> ST s (Int, Int)) -> (ShortByteString, ShortByteString)+createAndTrim2 maxLen1 maxLen2 fill = runST $ do- mba1 <- newByteArray l- mba2 <- newByteArray l- (l1, l2) <- fill mba1 mba2- sbs1 <- freeze' l1 mba1- sbs2 <- freeze' l2 mba2+ mba1 <- newByteArray maxLen1+ mba2 <- newByteArray maxLen2+ (len1, len2) <- fill mba1 mba2+ sbs1 <- freeze' len1 maxLen1 mba1+ sbs2 <- freeze' len2 maxLen2 mba2 pure (sbs1, sbs2) where- freeze' :: Int -> MBA s -> ST s ShortByteString- freeze' l' mba =- if assert (l' <= l) $ l' >= l+ freeze' :: Int -> Int -> MBA s -> ST s ShortByteString+ freeze' len maxLen mba =+ if assert (0 <= len && len <= maxLen) $ len >= maxLen then do BA# ba# <- unsafeFreezeByteArray mba return (SBS ba#) else do- mba2 <- newByteArray l'- copyMutableByteArray mba 0 mba2 0 l'+ mba2 <- newByteArray len+ copyMutableByteArray mba 0 mba2 0 len BA# ba# <- unsafeFreezeByteArray mba2 return (SBS ba#)-{-# INLINE createAndTrim'' #-}+{-# INLINE createAndTrim2 #-} isPinned :: ByteArray# -> Bool #if MIN_VERSION_base(4,10,0)@@ -648,13 +627,6 @@ ------------------------------------------------------------------------ -- Eq and Ord implementations -equateBytes :: ShortByteString -> ShortByteString -> Bool-equateBytes sbs1 sbs2 =- let !len1 = length sbs1- !len2 = length sbs2- in len1 == len2- && 0 == compareByteArrays (asBA sbs1) (asBA sbs2) len1- compareBytes :: ShortByteString -> ShortByteString -> Ordering compareBytes sbs1 sbs2 = let !len1 = length sbs1@@ -667,7 +639,6 @@ | len2 < len1 -> GT | otherwise -> EQ - ------------------------------------------------------------------------ -- Appending and concatenation @@ -675,7 +646,7 @@ append src1 src2 = let !len1 = length src1 !len2 = length src2- in create (len1 + len2) $ \dst -> do+ in create (checkedAdd "Short.append" len1 len2) $ \dst -> do copyByteArray (asBA src1) 0 dst 0 len1 copyByteArray (asBA src2) 0 dst len1 len2 @@ -683,8 +654,9 @@ concat = \sbss -> create (totalLen 0 sbss) (\dst -> copy dst 0 sbss) where- totalLen !acc [] = acc- totalLen !acc (sbs: sbss) = totalLen (acc + length sbs) sbss+ totalLen !acc [] = acc+ totalLen !acc (curr : rest)+ = totalLen (checkedAdd "Short.concat" acc $ length curr) rest copy :: MBA s -> Int -> [ShortByteString] -> ST s () copy !_ !_ [] = return ()@@ -705,11 +677,11 @@ -- -- @since 0.11.3.0 snoc :: ShortByteString -> Word8 -> ShortByteString-snoc = \sbs c -> let l = length sbs- nl = l + 1- in create nl $ \mba -> do- copyByteArray (asBA sbs) 0 mba 0 l- writeWord8Array mba l c+snoc = \sbs c -> let len = length sbs+ newLen = checkedAdd "Short.snoc" len 1+ in create newLen $ \mba -> do+ copyByteArray (asBA sbs) 0 mba 0 len+ writeWord8Array mba len c -- | /O(n)/ 'cons' is analogous to (:) for lists. --@@ -717,11 +689,11 @@ -- -- @since 0.11.3.0 cons :: Word8 -> ShortByteString -> ShortByteString-cons c = \sbs -> let l = length sbs- nl = l + 1- in create nl $ \mba -> do+cons c = \sbs -> let len = length sbs+ newLen = checkedAdd "Short.cons" len 1+ in create newLen $ \mba -> do writeWord8Array mba 0 c- copyByteArray (asBA sbs) 0 mba 1 l+ copyByteArray (asBA sbs) 0 mba 1 len -- | /O(1)/ Extract the last element of a ShortByteString, which must be finite and non-empty. -- An exception will be thrown in the case of an empty ShortByteString.@@ -1513,9 +1485,9 @@ -- -- @since 0.11.3.0 partition :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString)-partition k = \sbs -> let l = length sbs- in if | l <= 0 -> (sbs, sbs)- | otherwise -> createAndTrim'' l $ \mba1 mba2 -> go mba1 mba2 (asBA sbs) l+partition k = \sbs -> let len = length sbs+ in if | len <= 0 -> (sbs, sbs)+ | otherwise -> createAndTrim2 len len $ \mba1 mba2 -> go mba1 mba2 (asBA sbs) len where go :: forall s. MBA s -- mutable output bytestring1@@ -1602,8 +1574,6 @@ | otherwise = go (n + 1) in go 0 -- ------------------------------------------------------------------------ -- Exported low level operations @@ -1645,12 +1615,14 @@ #endif newByteArray :: Int -> ST s (MBA s)-newByteArray (I# len#) =+newByteArray len@(I# len#) =+ assert (len >= 0) $ ST $ \s -> case newByteArray# len# s of (# s', mba# #) -> (# s', MBA# mba# #) newPinnedByteArray :: Int -> ST s (MBA s)-newPinnedByteArray (I# len#) =+newPinnedByteArray len@(I# len#) =+ assert (len >= 0) $ ST $ \s -> case newPinnedByteArray# len# s of (# s', mba# #) -> (# s', MBA# mba# #)
bench/BenchAll.hs view
@@ -16,6 +16,7 @@ import Data.Foldable (foldMap) import Data.Monoid+import Data.Semigroup import Data.String import Test.Tasty.Bench import Prelude hiding (words)@@ -43,6 +44,7 @@ import BenchCount import BenchCSV import BenchIndices+import BenchReadInt import BenchShort ------------------------------------------------------------------------------@@ -418,6 +420,11 @@ , bench "lazy" $ nf L.tails lazyByteStringData ] , bgroup "sort" $ map (\s -> bench (S8.unpack s) $ nf S.sort s) sortInputs+ , bgroup "stimes" $ let st = stimes :: Int -> S.ByteString -> S.ByteString+ in+ [ bench "strict (tiny)" $ whnf (st 4) (S8.pack "test")+ , bench "strict (large)" $ whnf (st 50) byteStringData+ ] , bgroup "words" [ bench "lorem ipsum" $ nf S8.words loremIpsum , bench "one huge word" $ nf S8.words byteStringData@@ -490,5 +497,6 @@ , benchCount , benchCSV , benchIndices+ , benchReadInt , benchShort ]
+ bench/BenchReadInt.hs view
@@ -0,0 +1,144 @@+-- |+-- Copyright : (c) 2021 Viktor Dukhovni+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Viktor Dukhovni <ietf-dane@dukhovni.org>+--+-- Benchmark readInt and variants, readWord and variants,+-- readInteger and readNatural++{-# LANGUAGE+ CPP+ , BangPatterns+ , OverloadedStrings+ , TypeApplications+ , ScopedTypeVariables+ #-}++module BenchReadInt (benchReadInt) where++import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L+import Test.Tasty.Bench+import Data.Int+import Data.Word+import Numeric.Natural+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup((<>)))+#endif+import Data.Monoid (mconcat)++------------------------------------------------------------------------------+-- Benchmark+------------------------------------------------------------------------------++-- Sum space-separated integers in a ByteString.+loopS :: Integral a+ => (S.ByteString -> Maybe (a, S.ByteString)) -> S.ByteString -> a+loopS rd = go 0+ where+ go !acc !bs = case rd bs of+ Just (i, t) -> case S.uncons t of+ Just (_, t') -> go (acc + i) t'+ Nothing -> acc + i+ Nothing -> acc++-- Sum space-separated integers in a ByteString.+loopL :: Integral a+ => (L.ByteString -> Maybe (a, L.ByteString)) -> L.ByteString -> a+loopL rd = go 0+ where+ go !acc !bs = case rd bs of+ Just (i, t) -> case L.uncons t of+ Just (_, t') -> go (acc + i) t'+ Nothing -> acc + i+ Nothing -> acc++benchReadInt :: Benchmark+benchReadInt = bgroup "Read Integral"+ [ bgroup "Strict"+ [ bench "ReadInt" $ nf (loopS S.readInt) intS+ , bench "ReadInt8" $ nf (loopS S.readInt8) int8S+ , bench "ReadInt16" $ nf (loopS S.readInt16) int16S+ , bench "ReadInt32" $ nf (loopS S.readInt32) int32S+ , bench "ReadInt64" $ nf (loopS S.readInt64) int64S+ , bench "ReadWord" $ nf (loopS S.readWord) wordS+ , bench "ReadWord8" $ nf (loopS S.readWord8) word8S+ , bench "ReadWord16" $ nf (loopS S.readWord16) word16S+ , bench "ReadWord32" $ nf (loopS S.readWord32) word32S+ , bench "ReadWord64" $ nf (loopS S.readWord64) word64S+ , bench "ReadInteger" $ nf (loopS S.readInteger) bignatS+ , bench "ReadNatural" $ nf (loopS S.readNatural) bignatS+ , bench "ReadInteger small" $ nf (loopS S.readInteger) intS+ , bench "ReadNatural small" $ nf (loopS S.readNatural) wordS+ ]++ , bgroup "Lazy"+ [ bench "ReadInt" $ nf (loopL L.readInt) intL+ , bench "ReadInt8" $ nf (loopL L.readInt8) int8L+ , bench "ReadInt16" $ nf (loopL L.readInt16) int16L+ , bench "ReadInt32" $ nf (loopL L.readInt32) int32L+ , bench "ReadInt64" $ nf (loopL L.readInt64) int64L+ , bench "ReadWord" $ nf (loopL L.readWord) wordL+ , bench "ReadWord8" $ nf (loopL L.readWord8) word8L+ , bench "ReadWord16" $ nf (loopL L.readWord16) word16L+ , bench "ReadWord32" $ nf (loopL L.readWord32) word32L+ , bench "ReadWord64" $ nf (loopL L.readWord64) word64L+ , bench "ReadInteger" $ nf (loopL L.readInteger) bignatL+ , bench "ReadNatural" $ nf (loopL L.readNatural) bignatL+ , bench "ReadInteger small" $ nf (loopL L.readInteger) intL+ , bench "ReadNatural small" $ nf (loopL L.readNatural) wordL+ ]+ ]+ where+ mkWordL :: forall a. (Integral a, Bounded a)+ => (a -> B.Builder) -> L.ByteString+ mkWordL f = B.toLazyByteString b+ where b = mconcat [f i <> B.char8 ' ' | i <- [n-255..n]]+ n = maxBound @a+ mkWordS f = S.toStrict $ mkWordL f++ mkIntL :: forall a. (Integral a, Bounded a)+ => (a -> B.Builder) -> L.ByteString+ mkIntL f = B.toLazyByteString b+ where b = mconcat [f (i + 128) <> B.char8 ' ' | i <- [n-255..n]]+ n = maxBound @a+ mkIntS f = S.toStrict $ mkIntL f++ wordS, word8S, word16S, word32S, word64S :: S.ByteString+ !wordS = mkWordS B.wordDec+ !word8S = mkWordS B.word8Dec+ !word16S = mkWordS B.word16Dec+ !word32S = mkWordS B.word32Dec+ !word64S = mkWordS B.word64Dec++ intS, int8S, int16S, int32S, int64S :: S.ByteString+ !intS = mkIntS B.intDec+ !int8S = mkIntS B.int8Dec+ !int16S = mkIntS B.int16Dec+ !int32S = mkIntS B.int32Dec+ !int64S = mkIntS B.int64Dec++ word8L, word16L, word32L, word64L :: L.ByteString+ !wordL = mkWordL B.wordDec+ !word8L = mkWordL B.word8Dec+ !word16L = mkWordL B.word16Dec+ !word32L = mkWordL B.word32Dec+ !word64L = mkWordL B.word64Dec++ intL, int8L, int16L, int32L, int64L :: L.ByteString+ !intL = mkIntL B.intDec+ !int8L = mkIntL B.int8Dec+ !int16L = mkIntL B.int16Dec+ !int32L = mkIntL B.int32Dec+ !int64L = mkIntL B.int64Dec++ bignatL :: L.ByteString+ !bignatL = B.toLazyByteString b+ where b = mconcat [B.integerDec (powpow i) <> B.char8 ' ' | i <- [0..13]]+ powpow :: Word -> Integer+ powpow n = 2^(2^n :: Word)++ bignatS :: S.ByteString+ !bignatS = S.toStrict bignatL
bytestring.cabal view
@@ -1,5 +1,5 @@ Name: bytestring-Version: 0.11.5.4+Version: 0.12.0.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)@@ -74,6 +74,9 @@ library build-depends: base >= 4.9 && < 5, ghc-prim, deepseq, template-haskell + if impl(ghc < 9.4)+ build-depends: data-array-byte >= 0.1 && < 0.2+ exposed-modules: Data.ByteString Data.ByteString.Char8 Data.ByteString.Unsafe@@ -103,6 +106,10 @@ Data.ByteString.Builder.RealFloat.TableGenerator Data.ByteString.Internal.Type Data.ByteString.Lazy.Internal.Deque+ Data.ByteString.Lazy.ReadInt+ Data.ByteString.Lazy.ReadNat+ Data.ByteString.ReadInt+ Data.ByteString.ReadNat default-language: Haskell2010 other-extensions: CPP,@@ -182,6 +189,7 @@ BenchCount BenchCSV BenchIndices+ BenchReadInt BenchShort type: exitcode-stdio-1.0 hs-source-dirs: bench
cbits/aarch64/is-valid-utf8.c view
@@ -260,24 +260,20 @@ //'Roll back' our pointer a little to prepare for a slow search of the rest. uint32_t token; vst1q_lane_u32(&token, vreinterpretq_u32_u8(prev_input), 3);- uint8_t const *token_ptr = (uint8_t const *)&token;- ptrdiff_t rollback = 0;- // We must not roll back if no big blocks were processed, as then- // the fallback function would examine out-of-bounds data (#620).- // In that case, prev_input contains only nulls and we skip the if body.- if (token_ptr[3] >= 0x80u) {- // Look for an incomplete multi-byte code point- if (token_ptr[3] >= 0xC0u) {- rollback = 1;- } else if (token_ptr[2] >= 0xE0u) {- rollback = 2;- } else if (token_ptr[1] >= 0xF0u) {- rollback = 3;- }+ // 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 - rollback;- size_t const small_len = remaining + rollback;+ uint8_t const *const small_ptr = ptr - lookahead;+ size_t const small_len = remaining + lookahead; return is_valid_utf8_fallback(small_ptr, small_len); }
cbits/is-valid-utf8.c view
@@ -50,7 +50,6 @@ #endif #include <MachDeps.h>-#include "ghcplatform.h" #ifdef WORDS_BIGENDIAN #define to_little_endian(x) __builtin_bswap64(x)@@ -67,29 +66,6 @@ return r; } -// stand-in for __builtin_ctzll, used because __builtin_ctzll can-// cause runtime linker issues for GHC in some exotic situations (#601)-//-// See also these ghc issues:-// * https://gitlab.haskell.org/ghc/ghc/-/issues/21787-// * https://gitlab.haskell.org/ghc/ghc/-/issues/22011-static inline int hs_bytestring_ctz64(const uint64_t x) {- // These CPP conditions are taken from ghc-prim:- // https://gitlab.haskell.org/ghc/ghc/-/blob/73b5c7ce33929e1f7c9283ed7c2860aa40f6d0ec/libraries/ghc-prim/cbits/ctz.c#L31-57- // credit to Herbert Valerio Riedel, Erik de Castro Lopo-#if defined(__GNUC__) && (defined(i386_HOST_ARCH) || defined(powerpc_HOST_ARCH))- uint32_t xhi = (uint32_t)(x >> 32);- uint32_t xlo = (uint32_t) x;- return xlo ? __builtin_ctz(xlo) : 32 + __builtin_ctz(xhi);-#elif SIZEOF_UNSIGNED_LONG == 8- return __builtin_ctzl(x);-#elif SIZEOF_UNSIGNED_LONG_LONG == 8- return __builtin_ctzll(x);-#else-# error no suitable __builtin_ctz() found-#endif-}- static inline int is_valid_utf8_fallback(uint8_t const *const src, size_t const len) { uint8_t const *ptr = (uint8_t const *)src;@@ -124,16 +100,16 @@ if (results[3] == 0) { ptr += 8; } else {- ptr += (hs_bytestring_ctz64(results[3]) / 8);+ ptr += (__builtin_ctzll(results[3]) / 8); } } else {- ptr += (hs_bytestring_ctz64(results[2]) / 8);+ ptr += (__builtin_ctzll(results[2]) / 8); } } else {- ptr += (hs_bytestring_ctz64(results[1]) / 8);+ ptr += (__builtin_ctzll(results[1]) / 8); } } else {- ptr += (hs_bytestring_ctz64(results[0]) / 8);+ ptr += (__builtin_ctzll(results[0]) / 8); } } }@@ -231,16 +207,16 @@ if (result == 0) { ptr += 16; } else {- ptr += __builtin_ctz(result);+ ptr += __builtin_ctzll(result); } } else {- ptr += __builtin_ctz(result);+ ptr += __builtin_ctzll(result); } } else {- ptr += __builtin_ctz(result);+ ptr += __builtin_ctzll(result); } } else {- ptr += __builtin_ctz(result);+ ptr += __builtin_ctzll(result); } } }@@ -346,7 +322,7 @@ // +------------+---------------+------------------+----------------+ // | F0 | 3 | 3 | 6 | // +------------+---------------+------------------+----------------+-// | F4 | 3 | 4 | 7 |+// | F4 | 4 | 4 | 8 | // +------------+---------------+------------------+----------------+ // index1 -> E0, index14 -> ED static int8_t const df_ee_lookup[16] = {@@ -498,27 +474,20 @@ return 0; } // 'Roll back' our pointer a little to prepare for a slow search of the rest.- uint16_t tokens[2];+ int16_t tokens[2]; tokens[0] = _mm_extract_epi16(prev_input, 6); tokens[1] = _mm_extract_epi16(prev_input, 7);- uint8_t const *token_ptr = (uint8_t const *)tokens;- ptrdiff_t rollback = 0;- // We must not roll back if no big blocks were processed, as then- // the fallback function would examine out-of-bounds data (#620).- // In that case, prev_input contains only nulls and we skip the if body.- if (token_ptr[3] >= 0x80u) {- // Look for an incomplete multi-byte code point- if (token_ptr[3] >= 0xC0u) {- rollback = 1;- } else if (token_ptr[2] >= 0xE0u) {- rollback = 2;- } else if (token_ptr[1] >= 0xF0u) {- rollback = 3;- }+ 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; }- // Finish the job.- uint8_t const *const small_ptr = ptr - rollback;- size_t const small_len = remaining + rollback;+ uint8_t const *const small_ptr = ptr - lookahead;+ size_t const small_len = remaining + lookahead; return is_valid_utf8_fallback(small_ptr, small_len); } @@ -711,24 +680,17 @@ } // 'Roll back' our pointer a little to prepare for a slow search of the rest. uint32_t tokens_blob = _mm256_extract_epi32(prev_input, 7);- uint8_t const *token_ptr = (uint8_t const *)&tokens_blob;- ptrdiff_t rollback = 0;- // We must not roll back if no big blocks were processed, as then- // the fallback function would examine out-of-bounds data (#620).- // In that case, prev_input contains only nulls and we skip the if body.- if (token_ptr[3] >= 0x80u) {- // Look for an incomplete multi-byte code point- if (token_ptr[3] >= 0xC0u) {- rollback = 1;- } else if (token_ptr[2] >= 0xE0u) {- rollback = 2;- } else if (token_ptr[1] >= 0xF0u) {- rollback = 3;- }+ 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; }- // Finish the job.- uint8_t const *const small_ptr = ptr - rollback;- size_t const small_len = remaining + rollback;+ uint8_t const *const small_ptr = ptr - lookahead;+ size_t const small_len = remaining + lookahead; return is_valid_utf8_fallback(small_ptr, small_len); }
tests/IsValidUtf8.hs view
@@ -50,8 +50,7 @@ testProperty "Three invalid bytes between spaces" $ not $ B.isValidUtf8 threeBytesBetweenSpaces, testProperty "ASCII stride and invalid multibyte sequence" $- not $ B.isValidUtf8 asciiAndInvalidMultiByte,- testProperty "Splitting valid in two" splitValid+ not $ B.isValidUtf8 asciiAndInvalidMultiByte ] where tooHigh :: ByteString@@ -69,21 +68,13 @@ threeBytesBetweenSpaces = fromList $ replicate 125 32 ++ [242, 134, 159] ++ replicate 128 32 badBlockEnd :: Property- badBlockEnd =- forAllShrinkShow genBadBlock shrinkBadBlock showBadBlock $ \(BadBlock bs) ->+ badBlockEnd = + forAllShrinkShow genBadBlock shrinkBadBlock showBadBlock $ \(BadBlock bs) -> not . B.isValidUtf8 $ bs asciiAndInvalidMultiByte :: ByteString asciiAndInvalidMultiByte = fromList $ replicate 32 48 ++ [235, 185] - splitValid :: Property- splitValid = forAll genValidUtf8 $ \bs ->- forAll (choose (0, B.length bs)) $ \k ->- case B.splitAt k bs of- -- q may have non-zero offset, which- -- allows this property test to tickle #620- (p, q) -> B.isValidUtf8 p == B.isValidUtf8 q- -- Helpers -- A 128-byte sequence with a single bad byte at the end, with the rest being@@ -107,7 +98,7 @@ showBadBlock (BadBlock bs) = let asList = toList bs in foldr showHex "" asList -data Utf8Sequence =+data Utf8Sequence = One Word8 | Two Word8 Word8 | Three Word8 Word8 Word8 |@@ -125,7 +116,7 @@ genThree :: Gen Utf8Sequence genThree = do w1 <- elements [0xE0 .. 0xED]- w2 <- elements $ case w1 of+ w2 <- elements $ case w1 of 0xE0 -> [0xA0 .. 0xBF] 0xED -> [0x80 .. 0x9F] _ -> [0x80 .. 0xBF]@@ -134,7 +125,7 @@ genFour :: Gen Utf8Sequence genFour = do w1 <- elements [0xF0 .. 0xF4]- w2 <- elements $ case w1 of+ w2 <- elements $ case w1 of 0xF0 -> [0x90 .. 0xBF] 0xF4 -> [0x80 .. 0x8F] _ -> [0x80 .. 0xBF]@@ -142,46 +133,46 @@ w4 <- elements [0x80 .. 0xBF] pure . Four w1 w2 w3 $ w4 shrink = \case- One w1 -> One <$> case w1 of+ One w1 -> One <$> case w1 of 0x00 -> [] _ -> [0x00 .. (w1 - 1)]- Two w1 w2 -> case (w1, w2) of+ 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+ 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, _, _) ->+ (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 +++ case w1' of + 0xE0 -> (Three 0xE0 <$> [0xA0 .. 0xBF] <*> [0x80 .. 0xBF]) ++ + allTwos ++ allOnes- _ -> (Three w1' <$> [0x80 .. 0xBF] <*> [0x80 .. 0xBF]) ++- allTwos +++ _ -> (Three w1' <$> [0x80 .. 0xBF] <*> [0x80 .. 0xBF]) ++ + allTwos ++ allOnes- Four w1 w2 w3 w4 -> case (w1, w2, w3, w4) of+ 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)]) +++ (0xF0, 0x90, 0x80, _) -> + (Four 0xF0 0x90 0x80 <$> [0x80 .. (w4 - 1)]) ++ allThrees ++ allTwos ++ allOnes- (0xF0, 0x90, _, _) ->+ (0xF0, 0x90, _, _) -> (Four 0xF0 0x90 <$> [0x80 .. (w3 - 1)] <*> [0x80 .. (w4 - 1)]) ++ allThrees ++ allTwos ++ allOnes- (0xF0, _, _, _) ->+ (0xF0, _, _, _) -> (Four 0xF0 <$> [0x90 .. (w2 - 1)] <*> [0x80 .. (w3 - 1)] <*> [0x80 .. (w4 - 1)]) ++ allThrees ++ allTwos ++ allOnes _ -> do w1' <- [0xF0 .. (w1 - 1)]- case w1' of+ case w1' of 0xF0 -> (Four 0xF0 <$> [0x90 .. 0xBF] <*> [0x80 .. 0xBF] <*> [0x80 .. 0xBF]) ++ allThrees ++ allTwos ++@@ -198,7 +189,7 @@ allTwos = Two <$> [0xC2 .. 0xDF] <*> [0x80 .. 0xBF] allThrees :: [Utf8Sequence]-allThrees = (Three 0xE0 <$> [0xA0 .. 0xBF] <*> [0x80 .. 0xBF]) +++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])@@ -242,7 +233,7 @@ , InvalidUtf8 <$> genValidUtf8 <*> genInvalidUtf8 <*> pure mempty , InvalidUtf8 <$> genValidUtf8 <*> genInvalidUtf8 <*> genValidUtf8 ]- shrink (InvalidUtf8 p i s) =+ shrink (InvalidUtf8 p i s) = (InvalidUtf8 p i <$> shrinkValidBS s) ++ ((\p' -> InvalidUtf8 p' i s) <$> shrinkValidBS p) @@ -271,7 +262,7 @@ -- overlong encoding , do k <- choose (0, 0xFFFF) let c = chr k- case k of+ 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] ]@@ -288,7 +279,7 @@ vectorOf k gen genValidUtf8 :: Gen ByteString-genValidUtf8 = sized $ \size ->+genValidUtf8 = sized $ \size -> if size <= 0 then pure mempty else oneof [@@ -309,7 +300,7 @@ gen3Byte :: Gen ByteString gen3Byte = do b1 <- elements [0xE0 .. 0xED]- b2 <- elements $ case b1 of+ b2 <- elements $ case b1 of 0xE0 -> [0xA0 .. 0xBF] 0xED -> [0x80 .. 0x9F] _ -> [0x80 .. 0xBF]@@ -318,7 +309,7 @@ gen4Byte :: Gen ByteString gen4Byte = do b1 <- elements [0xF0 .. 0xF4]- b2 <- elements $ case b1 of+ b2 <- elements $ case b1 of 0xF0 -> [0x90 .. 0xBF] 0xF4 -> [0x80 .. 0x8F] _ -> [0x80 .. 0xBF]
tests/Properties.hs view
@@ -1,7 +1,16 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UnboxedTuples #-} +-- We need @AllowAmbiguousTypes@ in order to be able to use @TypeApplications@+-- to disambiguate the desired instance of class methods whose instance cannot+-- be inferred from the caller's context. We would otherwise have to use+-- proxy arguments. Here the 'RdInt' class methods used to generate tests for+-- all the various 'readInt' types require explicit type applications.+ module Properties (testSuite) where import Prelude hiding (head, tail)@@ -22,7 +31,9 @@ import Data.Char import Data.Word import Data.Maybe-import Data.Int (Int64)+import Data.Either (isLeft)+import Data.Bits (finiteBitSize, bit)+import Data.Int (Int8, Int16, Int32, Int64) import Data.Semigroup import GHC.Exts (Int(..), newPinnedByteArray#, unsafeFreezeByteArray#) import GHC.ST (ST(..), runST)@@ -47,7 +58,6 @@ 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@@ -97,15 +107,228 @@ 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+class (Bounded a, Integral a, Show a) => RdInt a where+ rdIntC :: C.ByteString -> Maybe (a, C.ByteString)+ rdIntD :: D.ByteString -> Maybe (a, D.ByteString)++instance RdInt Int where { rdIntC = C.readInt; rdIntD = D.readInt }+instance RdInt Int8 where { rdIntC = C.readInt8; rdIntD = D.readInt8 }+instance RdInt Int16 where { rdIntC = C.readInt16; rdIntD = D.readInt16 }+instance RdInt Int32 where { rdIntC = C.readInt32; rdIntD = D.readInt32 }+instance RdInt Int64 where { rdIntC = C.readInt64; rdIntD = D.readInt64 }+--+instance RdInt Word where { rdIntC = C.readWord; rdIntD = D.readWord }+instance RdInt Word8 where { rdIntC = C.readWord8; rdIntD = D.readWord8 }+instance RdInt Word16 where { rdIntC = C.readWord16; rdIntD = D.readWord16 }+instance RdInt Word32 where { rdIntC = C.readWord32; rdIntD = D.readWord32 }+instance RdInt Word64 where { rdIntC = C.readWord64; rdIntD = D.readWord64 }++smax :: forall a. (Bounded a, Show a) => String+smax = show $ maxBound @a+smax1 :: forall a. (Bounded a, Integral a) => String+smax1 = show $ fromIntegral @a @Integer maxBound + 1+smax10 :: forall a. (Bounded a, Integral a) => String+smax10 = show $ fromIntegral @a @Integer maxBound + 10++smin :: forall a. (Bounded a, Show a) => String+smin = show (minBound @a)+smin1 :: forall a. (Bounded a, Integral a) => String+smin1 = show $ fromIntegral @a @Integer minBound - 1+smin10 :: forall a. (Bounded a, Integral a) => String+smin10 = show $ fromIntegral @a @Integer minBound - 10++-- Ensure that readWord64 and readInteger over lazy ByteStrings are not -- excessively strict.-prop_readIntSafe = (fst . fromJust . D.readInt) (Chunk (C.pack "1z") Empty) == 1-prop_readIntUnsafe = (fst . fromJust . D.readInt) (Chunk (C.pack "2z") undefined) == 2+prop_readWordSafe = (fst . fromJust . D.readWord64) (Chunk (C.pack "1z") Empty) == 1+prop_readWordUnsafe = (fst . fromJust . D.readWord64) (Chunk (C.pack "2z") undefined) == 2 prop_readIntegerSafe = (fst . fromJust . D.readInteger) (Chunk (C.pack "1z") Empty) == 1 prop_readIntegerUnsafe = (fst . fromJust . D.readInteger) (Chunk (C.pack "2z") undefined) == 2+prop_readNaturalSafe = (fst . fromJust . D.readNatural) (Chunk (C.pack "1z") Empty) == 1+prop_readNaturalUnsafe = (fst . fromJust . D.readNatural) (Chunk (C.pack "2z") undefined) == 2+prop_readIntBoundsCC = rdWordBounds @Word+ && rdWordBounds @Word8+ && rdWordBounds @Word16+ && rdWordBounds @Word32+ && rdWordBounds @Word64+ && rdIntBounds @Int+ && rdIntBounds @Int8+ && rdIntBounds @Int16+ && rdIntBounds @Int32+ && rdIntBounds @Int64+ where+ tailStr = " tail"+ zeroStr = "000000000000000000000000000"+ spack s = C.pack $ s ++ tailStr+ spackPlus s = C.pack $ '+' : (s ++ tailStr)+ spackMinus s = C.pack $ '-' : (s ++ tailStr)+ spackLong s = C.pack $ s ++ zeroStr ++ tailStr+ spackZeros s = case s of+ '+':num -> C.pack $ '+' : zeroStr ++ num ++ tailStr+ '-':num -> C.pack $ '-' : zeroStr ++ num ++ tailStr+ num -> C.pack $ zeroStr ++ num ++ tailStr+ good i = Just (i, C.pack tailStr)+ --+ rdWordBounds :: forall a. RdInt a => Bool+ rdWordBounds =+ -- Upper bound+ rdIntC @a (spack (smax @a)) == good maxBound+ -- With leading zeros+ && rdIntC @a (spackZeros (smax @a)) == good maxBound+ -- Overflow in last digit+ && rdIntC @a (spack (smax1 @a)) == Nothing+ -- Overflow in 2nd-last digit+ && rdIntC @a (spack (smax10 @a)) == Nothing+ -- Trailing zeros+ && rdIntC @a (spackLong (smax @a)) == Nothing+ --+ rdIntBounds :: forall a. RdInt a => Bool+ rdIntBounds =+ rdWordBounds @a+ -- Lower bound+ && rdIntC @a (spack (smin @a)) == good minBound+ -- With leading signs+ && rdIntC @a (spackPlus (smax @a)) == good maxBound+ && rdIntC @a (spackMinus (smax @a)) == good (negate maxBound)+ -- With leading zeros+ && rdIntC @a (spackZeros (smax @a)) == good maxBound+ -- Underflow in last digit+ && rdIntC @a (spack (smin1 @a)) == Nothing+ -- Underflow in 2nd-last digit+ && rdIntC @a (spack (smin10 @a)) == Nothing+ -- Trailing zeros+ && rdIntC @a (spackLong (smin @a)) == Nothing +prop_readIntBoundsLC = rdWordBounds @Word+ && rdWordBounds @Word8+ && rdWordBounds @Word16+ && rdWordBounds @Word32+ && rdWordBounds @Word64+ && rdIntBounds @Int+ && rdIntBounds @Int8+ && rdIntBounds @Int16+ && rdIntBounds @Int32+ && rdIntBounds @Int64+ where+ tailStr = " tail"+ zeroStr = "000000000000000000000000000"+ spack s = LC.pack $ s ++ tailStr+ spackPlus s = LC.singleton '+' `D.append` LC.pack s `D.append` LC.pack tailStr+ spackMinus s = LC.singleton '-' `D.append` LC.pack s `D.append` LC.pack tailStr+ spackLong1 s = LC.pack s `D.append` LC.pack zeroStr `D.append` LC.pack tailStr+ spackLong2 s = LC.pack (s ++ zeroStr) `D.append` LC.pack tailStr+ spackZeros s = case s of+ '+':num -> LC.pack ('+' : zeroStr) `D.append` LC.pack (num ++ tailStr)+ '-':num -> LC.pack ('-' : zeroStr) `D.append` LC.pack (num ++ tailStr)+ num -> LC.pack $ zeroStr ++ num ++ tailStr+ good i = Just (i, LC.pack tailStr)+ --+ rdWordBounds :: forall a. RdInt a => Bool+ rdWordBounds =+ -- Upper bound+ rdIntD @a (spack (smax @a)) == good maxBound+ -- With leading zeros+ && rdIntD @a (spackZeros (smax @a)) == good maxBound+ -- Overflow in last digit+ && rdIntD @a (spack (smax1 @a)) == Nothing+ -- Overflow in 2nd-last digit+ && rdIntD @a (spack (smax10 @a)) == Nothing+ -- Overflow across chunk boundary+ && rdIntD @a (spackLong1 (smax @a)) == Nothing+ -- Overflow within chunk+ && rdIntD @a (spackLong2 (smax @a)) == Nothing+ -- Sign with no digits+ && rdIntD @a (LC.pack "+ foo") == Nothing+ && rdIntD @a (LC.pack "-bar") == Nothing+ --+ rdIntBounds :: forall a. RdInt a => Bool+ rdIntBounds =+ rdWordBounds @a+ -- Lower bound+ && rdIntD @a (spack (smin @a)) == good minBound+ -- With leading signs+ && rdIntD @a (spackPlus (smax @a)) == good maxBound+ && rdIntD @a (spackMinus (smax @a)) == good (negate maxBound)+ -- With leading zeros+ && rdIntD @a (spackZeros (smin @a)) == good minBound+ -- Overflow in last digit+ && rdIntD @a (spack (smin1 @a)) == Nothing+ -- Overflow in 2nd-last digit+ && rdIntD @a (spack (smin10 @a)) == Nothing+ -- Overflow across chunk boundary+ && rdIntD @a (spackLong1 (smin @a)) == Nothing+ -- Overflow within chunk+ && rdIntD @a (spackLong2 (smin @a)) == Nothing+ ------------------------------------------------------------------------ +expectSizeOverflow :: a -> Property+expectSizeOverflow val = ioProperty $ do+ isLeft <$> try @P.SizeOverflowException (evaluate val)++prop_checkedAdd = forAll (vectorOf 2 nonNeg) $ \[x, y] -> if oflo x y+ then expectSizeOverflow (P.checkedAdd "" x y)+ else property $ P.checkedAdd "" x y == x + y+ where nonNeg = choose (0, (maxBound @Int))+ oflo x y = toInteger x + toInteger y /= toInteger @Int (x + y)++multCompl :: Int -> Gen Int+multCompl x = choose (0, fromInteger @Int maxc)+ -- This choice creates products with magnitude roughly in the range+ -- [0..5*(maxBound @Int)], which results in a roughly even split+ -- between positive and negative overflowed Int results, while still+ -- producing a fair number of non-overflowing products.+ where maxc = toInteger (maxBound @Int) * 5 `quot` max 5 (abs $ toInteger x)++prop_checkedMultiply = forAll genScale $ \scale ->+ forAll (genVal scale) $ \x ->+ forAll (multCompl x) $ \y -> if oflo x y+ then expectSizeOverflow (P.checkedMultiply "" x y)+ else property $ P.checkedMultiply "" x y == x * y+ where genScale = choose (0, finiteBitSize @Int 0 - 1)+ genVal scale = choose (0, bit scale - 1)+ oflo x y = toInteger x * toInteger y /= toInteger @Int (x * y)++prop_stimesOverflowBasic bs = forAll (multCompl len) $ \n ->+ toInteger n * toInteger len > maxInt ==> expectSizeOverflow (stimes n bs)+ where+ maxInt = toInteger @Int (maxBound @Int)+ len = P.length bs++prop_stimesOverflowScary bs =+ -- "Scary" because this test will cause heap corruption+ -- (not just memory exhaustion) with the old stimes implementation.+ n > 1 ==> expectSizeOverflow (stimes reps bs)+ where+ n = P.length bs+ reps = maxBound @Word `quot` fromIntegral @Int @Word n + 1++prop_stimesOverflowEmpty = forAll (choose (0, maxBound @Word)) $ \n ->+ stimes n mempty === mempty @P.ByteString++concat32bitOverflow :: (Int -> a) -> ([a] -> a) -> Property+concat32bitOverflow replicateLike concatLike = let+ intBits = finiteBitSize @Int 0+ largeBS = concatLike $ replicate (bit 14) $ replicateLike (bit 17)+ in if intBits /= 32+ then label "skipped due to non-32-bit Int" True+ else expectSizeOverflow largeBS++prop_32bitOverflow_Strict_mconcat :: Property+prop_32bitOverflow_Strict_mconcat =+ concat32bitOverflow (`P.replicate` 0) mconcat++prop_32bitOverflow_Lazy_toStrict :: Property+prop_32bitOverflow_Lazy_toStrict =+ concat32bitOverflow (`P.replicate` 0) (L.toStrict . L.fromChunks)++prop_32bitOverflow_Short_mconcat :: Property+prop_32bitOverflow_Short_mconcat =+ concat32bitOverflow makeShort mconcat+ where makeShort n = Short.toShort $ P.replicate n 0+++------------------------------------------------------------------------+ prop_packUptoLenBytes cs = forAll (choose (0, length cs + 1)) $ \n -> let (bs, cs') = P.packUptoLenBytes n cs@@ -417,6 +640,7 @@ , testGroup "StrictChar8" PropBS8.tests , testGroup "LazyWord8" PropBL.tests , testGroup "LazyChar8" PropBL8.tests+ , testGroup "Overflow" overflow_tests , testGroup "Misc" misc_tests , testGroup "IO" io_tests , testGroup "Short" short_tests@@ -437,6 +661,17 @@ , testProperty "packAddress " prop_packAddress ] +overflow_tests =+ [ testProperty "checkedAdd" prop_checkedAdd+ , testProperty "checkedMultiply" prop_checkedMultiply+ , testProperty "StrictByteString stimes (basic)" prop_stimesOverflowBasic+ , testProperty "StrictByteString stimes (scary)" prop_stimesOverflowScary+ , testProperty "StrictByteString stimes (empty)" prop_stimesOverflowEmpty+ , testProperty "StrictByteString mconcat" prop_32bitOverflow_Strict_mconcat+ , testProperty "LazyByteString toStrict" prop_32bitOverflow_Lazy_toStrict+ , testProperty "ShortByteString mconcat" prop_32bitOverflow_Short_mconcat+ ]+ misc_tests = [ testProperty "packUptoLenBytes" prop_packUptoLenBytes , testProperty "packUptoLenChars" prop_packUptoLenChars@@ -475,10 +710,14 @@ , testProperty "strip" prop_strip , testProperty "isSpace" prop_isSpaceWord8 - , testProperty "readIntSafe" prop_readIntSafe- , testProperty "readIntUnsafe" prop_readIntUnsafe+ , testProperty "readWordSafe" prop_readWordSafe+ , testProperty "readWordUnsafe" prop_readWordUnsafe+ , testProperty "readIntBoundsCC" prop_readIntBoundsCC+ , testProperty "readIntBoundsLC" prop_readIntBoundsLC , testProperty "readIntegerSafe" prop_readIntegerSafe , testProperty "readIntegerUnsafe" prop_readIntegerUnsafe+ , testProperty "readNaturalSafe" prop_readNaturalSafe+ , testProperty "readNaturalUnsafe" prop_readNaturalUnsafe ] strictness_checks =
tests/Properties/ByteString.hs view
@@ -4,8 +4,17 @@ -- License : BSD-style {-# LANGUAGE CPP #-}+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} +-- We need @AllowAmbiguousTypes@ in order to be able to use @TypeApplications@+-- to disambiguate the desired instance of class methods whose instance cannot+-- be inferred from the caller's context. We would otherwise have to use+-- proxy arguments. Here the 'RdInt' class methods used to generate tests for+-- all the various 'readInt' types require explicit type applications.+ -- We are happy to sacrifice optimizations in exchange for faster compilation, -- but need to test rewrite rules. As one can check using -ddump-rule-firings, -- rewrite rules do not fire in -O0 mode, so we use -O1, but disable almost all@@ -36,8 +45,6 @@ import qualified Data.ByteString.Lazy as B #endif -import Data.Word- #else #ifndef BYTESTRING_LAZY@@ -50,6 +57,9 @@ #define BYTESTRING_TYPE B.ByteString #endif +import Data.Int+import Numeric.Natural (Natural)+ import Text.Read #endif@@ -63,6 +73,7 @@ import Data.Semigroup import Data.String import Data.Tuple+import Data.Word import Test.Tasty import Test.Tasty.QuickCheck import QuickCheckUtils@@ -73,6 +84,42 @@ #else toElem :: Char8 -> Char toElem (Char8 c) = c++class (Integral a, Show a) => RdInt a where+ bread :: BYTESTRING_TYPE -> Maybe (a, BYTESTRING_TYPE)+ sread :: String -> Maybe (a, String)++instance RdInt Int where { bread = B.readInt; sread = readInt }+instance RdInt Int8 where { bread = B.readInt8; sread = readInt8 }+instance RdInt Int16 where { bread = B.readInt16; sread = readInt16 }+instance RdInt Int32 where { bread = B.readInt32; sread = readInt32 }+instance RdInt Int64 where { bread = B.readInt64; sread = readInt64 }+--+instance RdInt Word where { bread = B.readWord; sread = readWord }+instance RdInt Word8 where { bread = B.readWord8; sread = readWord8 }+instance RdInt Word16 where { bread = B.readWord16; sread = readWord16 }+instance RdInt Word32 where { bread = B.readWord32; sread = readWord32 }+instance RdInt Word64 where { bread = B.readWord64; sread = readWord64 }+--+instance RdInt Integer where { bread = B.readInteger; sread = readInteger }+instance RdInt Natural where { bread = B.readNatural; sread = readNatural }++instance Arbitrary Natural where+ arbitrary = i2n <$> arbitrary+ where i2n :: Integer -> Natural+ i2n i | i >= 0 = fromIntegral i+ | otherwise = fromIntegral $ negate i++testRdInt :: forall a. (Arbitrary a, RdInt a) => String -> TestTree+testRdInt s = testGroup s $+ [ testProperty "from string" $ \ prefix value suffix ->+ let si = show @a value+ b = prefix <> B.pack si <> suffix+ in fmap (second B.unpack) (bread @a b)+ === sread @a (B.unpack prefix ++ si ++ B.unpack suffix)+ , testProperty "from number" $ \n ->+ bread @a (B.pack (show n)) === Just (n, B.empty)+ ] #endif tests :: [TestTree]@@ -558,14 +605,18 @@ #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)+ , testRdInt @Int "readInt"+ , testRdInt @Int8 "readInt8"+ , testRdInt @Int16 "readInt16"+ , testRdInt @Int32 "readInt32"+ , testRdInt @Int64 "readInt64"+ , testRdInt @Word "readWord"+ , testRdInt @Word8 "readWord8"+ , testRdInt @Word16 "readWord16"+ , testRdInt @Word32 "readWord32"+ , testRdInt @Word64 "readWord64"+ , testRdInt @Integer "readInteger"+ , testRdInt @Natural "readNatural" , testProperty "lines" $ \x -> map B.unpack (B.lines x) === lines (B.unpack x) , testProperty "lines \\n" $ once $@@ -648,10 +699,70 @@ | y' <- fromInteger y, toInteger y' == y -> Just (y', zs) otherwise -> Nothing +readWord :: String -> Maybe (Word, String)+readWord xs = case readIntegerUnsigned xs of+ Just (y, zs)+ | y' <- fromInteger y, toInteger y' == y -> Just (y', zs)+ otherwise -> Nothing++readInt8 :: String -> Maybe (Int8, String)+readInt8 xs = case readInteger xs of+ Just (y, zs)+ | y' <- fromInteger y, toInteger y' == y -> Just (y', zs)+ otherwise -> Nothing++readWord8 :: String -> Maybe (Word8, String)+readWord8 xs = case readIntegerUnsigned xs of+ Just (y, zs)+ | y' <- fromInteger y, toInteger y' == y -> Just (y', zs)+ otherwise -> Nothing++readInt16 :: String -> Maybe (Int16, String)+readInt16 xs = case readInteger xs of+ Just (y, zs)+ | y' <- fromInteger y, toInteger y' == y -> Just (y', zs)+ otherwise -> Nothing++readWord16 :: String -> Maybe (Word16, String)+readWord16 xs = case readIntegerUnsigned xs of+ Just (y, zs)+ | y' <- fromInteger y, toInteger y' == y -> Just (y', zs)+ otherwise -> Nothing++readInt32 :: String -> Maybe (Int32, String)+readInt32 xs = case readInteger xs of+ Just (y, zs)+ | y' <- fromInteger y, toInteger y' == y -> Just (y', zs)+ otherwise -> Nothing++readWord32 :: String -> Maybe (Word32, String)+readWord32 xs = case readIntegerUnsigned xs of+ Just (y, zs)+ | y' <- fromInteger y, toInteger y' == y -> Just (y', zs)+ otherwise -> Nothing++readInt64 :: String -> Maybe (Int64, String)+readInt64 xs = case readInteger xs of+ Just (y, zs)+ | y' <- fromInteger y, toInteger y' == y -> Just (y', zs)+ otherwise -> Nothing++readWord64 :: String -> Maybe (Word64, String)+readWord64 xs = case readIntegerUnsigned xs of+ Just (y, zs)+ | y' <- fromInteger y, toInteger y' == y -> Just (y', zs)+ otherwise -> Nothing+ readInteger :: String -> Maybe (Integer, String) readInteger ('+' : xs) = readIntegerUnsigned xs readInteger ('-' : xs) = fmap (first negate) (readIntegerUnsigned xs) readInteger xs = readIntegerUnsigned xs++readNatural :: String -> Maybe (Natural, String)+readNatural xs = case readIntegerUnsigned xs of+ Just (y, zs)+ | y >= 0 -> Just (fromIntegral @Integer @Natural y, zs)+ _ -> Nothing readIntegerUnsigned :: String -> Maybe (Integer, String) readIntegerUnsigned xs = case readMaybe ys of