diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,16 @@ +[0.11.3.0] — February 2022 + +* [Enhance `ShortByteString` API](https://github.com/haskell/bytestring/pull/471) + - Add `all`, `any`, `append`, `break`, `breakEnd`, `breakSubstring`, `concat`, `cons`, `count`, `drop`, `dropEnd`, `dropWhile`, `dropWhileEnd`, `elem`, `elemIndex`, `elemIndices`, `filter`, `find`, `findIndex`, `findIndices`, `foldl'`, `foldl`, `foldl1'`, `foldl1`, `foldr'`, `foldr`, `foldr1'`, `foldr1`, `head`, `init`, `intercalate`, `isInfixOf`, `isPrefixOf`, `isSuffixOf`, `last`, `map`, `partition`, `replicate`, `reverse`, `singleton`, `snoc`, `span`, `spanEnd`, `split`, `splitAt`, `splitWith`, `stripPrefix`, `stripSuffix`, `tail`, `take`, `takeEnd`, `takeWhile`, `takeWhileEnd`, `uncons`, `unfoldr`, `unfoldrN`, `unsnoc` to `Data.ByteString.Short`. +* [Add `Data.ByteString.Short.isValidUtf8`](https://github.com/haskell/bytestring/pull/450) +* [Use safe `isValidUtf8` for large inputs](https://github.com/haskell/bytestring/pull/470) +* [Make `unlines` lazier](https://github.com/haskell/bytestring/pull/477) +* [Improve performance of `unlines`](https://github.com/haskell/bytestring/pull/479) +* [Make `singleton` return a slice of a static buffer](https://github.com/haskell/bytestring/pull/480) +* [Improve performance of `intercalate`](https://github.com/haskell/bytestring/pull/459) + +[0.11.3.0]: https://github.com/haskell/bytestring/compare/0.11.2.0...0.11.3.0 + [0.11.2.0] — December 2021 * [Add `Data.ByteString.isValidUtf8`](https://github.com/haskell/bytestring/pull/423) diff --git a/Data/ByteString.hs b/Data/ByteString.hs --- a/Data/ByteString.hs +++ b/Data/ByteString.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_HADDOCK prune #-} @@ -274,35 +275,24 @@ -- ----------------------------------------------------------------------------- -- Introducing and eliminating 'ByteString's --- | /O(1)/ The empty 'ByteString' -empty :: ByteString -empty = BS nullForeignPtr 0 - -- | /O(1)/ Convert a 'Word8' into a 'ByteString' singleton :: Word8 -> ByteString -singleton c = unsafeCreate 1 $ \p -> poke p c -{-# INLINE [1] singleton #-} - --- Inline [1] for intercalate rule +-- Taking a slice of some static data rather than allocating a new +-- buffer for each call is nice for several reasons. Since it doesn't +-- involve any side effects hidden in a 'GHC.Magic.runRW#' call, it +-- can be simplified to a constructor application. This may enable GHC +-- to perform further optimizations after inlining, and also causes a +-- fresh singleton to take only 4 words of heap space instead of 9. +-- (The buffer object itself would take up 3 words: header, size, and +-- 1 word of content. The ForeignPtrContents object used to keep the +-- buffer alive would need two more.) +singleton c = unsafeTake 1 $ unsafeDrop (fromIntegral c) allBytes +{-# INLINE singleton #-} --- --- XXX The use of unsafePerformIO in allocating functions (unsafeCreate) is critical! --- --- Otherwise: --- --- singleton 255 `compare` singleton 127 --- --- is compiled to: --- --- case mallocByteString 2 of --- ForeignPtr f internals -> --- case writeWord8OffAddr# f 0 255 of _ -> --- case writeWord8OffAddr# f 0 127 of _ -> --- case eqAddr# f f of --- False -> case compare (GHC.Prim.plusAddr# f 0) --- (GHC.Prim.plusAddr# f 0) --- --- +-- | A static blob of all possible bytes (0x00 to 0xff) in order +allBytes :: ByteString +allBytes = unsafePackLenLiteral 0x100 + "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\xdd\xde\xdf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff"# -- | /O(n)/ Convert a @['Word8']@ into a 'ByteString'. -- @@ -387,13 +377,13 @@ cons :: Word8 -> ByteString -> ByteString cons c (BS x l) = unsafeCreate (l+1) $ \p -> unsafeWithForeignPtr x $ \f -> do poke p c - memcpy (p `plusPtr` 1) f (fromIntegral l) + memcpy (p `plusPtr` 1) f l {-# INLINE cons #-} -- | /O(n)/ Append a byte to the end of a 'ByteString' snoc :: ByteString -> Word8 -> ByteString snoc (BS x l) c = unsafeCreate (l+1) $ \p -> unsafeWithForeignPtr x $ \f -> do - memcpy p f (fromIntegral l) + memcpy p f l poke (p `plusPtr` l) c {-# INLINE snoc #-} @@ -961,7 +951,7 @@ | otherwise = (BS x n, BS (plusForeignPtr x n) (l-n)) {-# INLINE splitAt #-} --- | Similar to 'P.takeWhile', +-- | Similar to 'Prelude.takeWhile', -- returns the longest (possibly empty) prefix of elements -- satisfying the predicate. takeWhile :: (Word8 -> Bool) -> ByteString -> ByteString @@ -989,7 +979,7 @@ takeWhileEnd f ps = unsafeDrop (findFromEndUntil (not . f) ps) ps {-# INLINE takeWhileEnd #-} --- | Similar to 'P.dropWhile', +-- | Similar to 'Prelude.dropWhile', -- drops the longest (possibly empty) prefix of elements -- satisfying the predicate and returns the remainder. dropWhile :: (Word8 -> Bool) -> ByteString -> ByteString @@ -1007,7 +997,7 @@ dropWhile (`eqWord8` x) = snd . spanByte x #-} --- | Similar to 'P.dropWhileEnd', +-- | Similar to 'Prelude.dropWhileEnd', -- drops the longest (possibly empty) suffix of elements -- satisfying the predicate and returns the remainder. -- @@ -1018,7 +1008,7 @@ dropWhileEnd f ps = unsafeTake (findFromEndUntil (not . f) ps) ps {-# INLINE dropWhileEnd #-} --- | Similar to 'P.break', +-- | Similar to 'Prelude.break', -- returns the longest (possibly empty) prefix of elements which __do not__ -- satisfy the predicate and the remainder of the string. -- @@ -1064,7 +1054,7 @@ breakEnd :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) breakEnd p ps = splitAt (findFromEndUntil p ps) ps --- | Similar to 'P.span', +-- | Similar to 'Prelude.span', -- returns the longest (possibly empty) prefix of elements -- satisfying the predicate and the remainder of the string. -- @@ -1213,27 +1203,24 @@ -- 'ByteString's and concatenates the list after interspersing the first -- argument between each element of the list. intercalate :: ByteString -> [ByteString] -> ByteString -intercalate s = concat . List.intersperse s -{-# INLINE [1] intercalate #-} - -{-# RULES -"ByteString specialise intercalate c -> intercalateByte" forall c s1 s2 . - intercalate (singleton c) [s1, s2] = intercalateWithByte c s1 s2 - #-} - --- | /O(n)/ intercalateWithByte. An efficient way to join to two ByteStrings --- with a char. Around 4 times faster than the generalised join. --- -intercalateWithByte :: Word8 -> ByteString -> ByteString -> ByteString -intercalateWithByte c f@(BS ffp l) g@(BS fgp m) = unsafeCreate len $ \ptr -> - unsafeWithForeignPtr ffp $ \fp -> - unsafeWithForeignPtr fgp $ \gp -> do - memcpy ptr fp (fromIntegral l) - poke (ptr `plusPtr` l) c - memcpy (ptr `plusPtr` (l + 1)) gp (fromIntegral m) - where - len = length f + length g + 1 -{-# INLINE intercalateWithByte #-} +intercalate _ [] = mempty +intercalate _ [x] = x -- This branch exists for laziness, not speed +intercalate (BS fSepPtr sepLen) (BS fhPtr hLen : t) = + unsafeCreate totalLen $ \dstPtr0 -> + unsafeWithForeignPtr fSepPtr $ \sepPtr -> do + unsafeWithForeignPtr fhPtr $ \hPtr -> + memcpy dstPtr0 hPtr hLen + let go _ [] = pure () + go dstPtr (BS fChunkPtr chunkLen : chunks) = do + memcpy dstPtr sepPtr sepLen + let destPtr' = dstPtr `plusPtr` sepLen + unsafeWithForeignPtr fChunkPtr $ \chunkPtr -> + memcpy destPtr' chunkPtr chunkLen + go (destPtr' `plusPtr` chunkLen) chunks + go (dstPtr0 `plusPtr` hLen) t + where + totalLen = List.foldl' (\acc (BS _ chunkLen) -> acc + chunkLen + sepLen) hLen t +{-# INLINE intercalate #-} -- --------------------------------------------------------------------- -- Indexing ByteStrings @@ -1535,13 +1522,29 @@ -- -- @since 0.11.2.0 isValidUtf8 :: ByteString -> Bool -isValidUtf8 (BS ptr len) = accursedUnutterablePerformIO $ unsafeWithForeignPtr ptr $ \p -> do - i <- cIsValidUtf8 p (fromIntegral len) +isValidUtf8 (BS ptr len) = accursedUnutterablePerformIO $ unsafeWithForeignPtr ptr $ \p -> do + -- Use a safe FFI call for large inputs to avoid GC synchronization pauses + -- in multithreaded contexts. + -- This specific limit was chosen based on results of a simple benchmark, see: + -- https://github.com/haskell/bytestring/issues/451#issuecomment-991879338 + -- When changing this function, also consider changing the related function: + -- Data.ByteString.Short.Internal.isValidUtf8 + i <- if len < 1000000 + then cIsValidUtf8 p (fromIntegral len) + else cIsValidUtf8Safe p (fromIntegral len) pure $ i /= 0 +-- We import bytestring_is_valid_utf8 both unsafe and safe. For small inputs +-- we can use the unsafe version to get a bit more performance, but for large +-- inputs the safe version should be used to avoid GC synchronization pauses +-- in multithreaded contexts. + foreign import ccall unsafe "bytestring_is_valid_utf8" cIsValidUtf8 :: Ptr Word8 -> CSize -> IO CInt +foreign import ccall safe "bytestring_is_valid_utf8" cIsValidUtf8Safe + :: Ptr Word8 -> CSize -> IO CInt + -- | Break a string on a substring, returning a pair of the part of the -- string prior to the match, and the rest of the string. -- @@ -1701,7 +1704,7 @@ sort (BS input l) -- qsort outperforms counting sort for small arrays | l <= 20 = unsafeCreate l $ \ptr -> unsafeWithForeignPtr input $ \inp -> do - memcpy ptr inp (fromIntegral l) + memcpy ptr inp l c_sort ptr (fromIntegral l) | otherwise = unsafeCreate l $ \p -> allocaArray 256 $ \arr -> do @@ -1738,7 +1741,7 @@ allocaBytes (l+1) $ \buf -> -- Cannot use unsafeWithForeignPtr, because action can diverge withForeignPtr fp $ \p -> do - memcpy buf p (fromIntegral l) + memcpy buf p l pokeByteOff buf l (0::Word8) action (castPtr buf) @@ -1765,7 +1768,7 @@ -- Haskell heap. packCStringLen :: CStringLen -> IO ByteString packCStringLen (cstr, len) | len >= 0 = create len $ \p -> - memcpy p (castPtr cstr) (fromIntegral len) + memcpy p (castPtr cstr) len packCStringLen (_, len) = moduleErrorIO "packCStringLen" ("negative length: " ++ show len) @@ -1779,7 +1782,7 @@ -- copy :: ByteString -> ByteString copy (BS x l) = unsafeCreate l $ \p -> unsafeWithForeignPtr x $ \f -> - memcpy p f (fromIntegral l) + memcpy p f l -- --------------------------------------------------------------------- -- Line IO diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -86,7 +86,7 @@ #include #include "MachDeps.h" -#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ < 903 +#if WORD_SIZE_IN_BITS < 64 && !MIN_VERSION_ghc_prim(0,8,0) import GHC.IntWord64 #endif diff --git a/Data/ByteString/Char8.hs b/Data/ByteString/Char8.hs --- a/Data/ByteString/Char8.hs +++ b/Data/ByteString/Char8.hs @@ -248,7 +248,7 @@ import qualified Data.ByteString.Unsafe as B -- Listy functions transparently exported -import Data.ByteString (empty,null,length,tail,init,append +import Data.ByteString (null,length,tail,init,append ,inits,tails,reverse,transpose ,concat,take,takeEnd,drop,dropEnd,splitAt ,intercalate,sort,isPrefixOf,isSuffixOf @@ -268,7 +268,7 @@ import Data.Char ( isSpace ) -- See bytestring #70 import GHC.Char (eqChar) -import qualified Data.List as List (intersperse) +import qualified Data.List as List import System.IO (Handle,stdout) import Foreign @@ -522,7 +522,7 @@ dropWhile isSpace = dropSpace #-} --- | 'dropWhile' @p xs@ returns the prefix remaining after 'takeWhileEnd' @p +-- | 'dropWhileEnd' @p xs@ returns the prefix remaining after 'takeWhileEnd' @p -- xs@. -- -- @since 0.10.12.0 @@ -959,12 +959,21 @@ else return [BS f i] -} --- | 'unlines' is an inverse operation to 'lines'. It joins lines, --- after appending a terminating newline to each. +-- | 'unlines' joins lines, appending a terminating newline after each. +-- +-- Equivalent to +-- @'concat' . Data.List.concatMap (\\x -> [x, 'singleton' \'\\n'])@. unlines :: [ByteString] -> ByteString -unlines [] = empty -unlines ss = concat (List.intersperse nl ss) `append` nl -- half as much space - where nl = singleton '\n' +unlines = \li -> let + totLen = List.foldl' (\acc s -> acc +! length s +! 1) 0 li + (+!) = checkedAdd "Char8.unlines" + + go [] _ = pure () + go (BS srcFP len : srcs) dest = do + unsafeWithForeignPtr srcFP $ \src -> memcpy dest src len + pokeElemOff dest len (c2w '\n') + go srcs $ dest `plusPtr` (len + 1) + in unsafeCreate totLen (go li) -- | 'words' breaks a ByteString up into a list of words, which -- were delimited by Chars representing white space. diff --git a/Data/ByteString/Internal.hs b/Data/ByteString/Internal.hs --- a/Data/ByteString/Internal.hs +++ b/Data/ByteString/Internal.hs @@ -47,6 +47,7 @@ unsafePackLiteral, unsafePackLenLiteral, -- * Low level imperative construction + empty, create, createUptoN, createUptoN', @@ -239,7 +240,7 @@ stimes = times instance Monoid ByteString where - mempty = BS nullForeignPtr 0 + mempty = empty mappend = (<>) mconcat = concat @@ -651,6 +652,13 @@ EQ -> len1 `compare` len2 x -> x + +-- | /O(1)/ The empty 'ByteString' +empty :: ByteString +-- This enables bypassing #457 by not using (polymorphic) mempty in +-- any definitions used by the (Monoid ByteString) instance +empty = BS nullForeignPtr 0 + append :: ByteString -> ByteString -> ByteString append (BS _ 0) b = b append a (BS _ 0) = a @@ -680,7 +688,7 @@ -- closures which would result in unnecessary closure allocation. where -- It's still possible that the result is empty - goLen0 _ [] = mempty + goLen0 _ [] = empty goLen0 bss0 (BS _ 0 :bss) = goLen0 bss0 bss goLen0 bss0 (bs :bss) = goLen1 bss0 bs bss @@ -705,8 +713,8 @@ {-# NOINLINE concat #-} {-# RULES -"ByteString concat [] -> mempty" - concat [] = mempty +"ByteString concat [] -> empty" + concat [] = empty "ByteString concat [bs] -> bs" forall x. concat [x] = x #-} @@ -715,9 +723,9 @@ times :: Integral a => a -> ByteString -> ByteString times n (BS fp len) | n < 0 = error "stimes: non-negative multiplier expected" - | n == 0 = mempty + | n == 0 = empty | n == 1 = BS fp len - | len == 0 = mempty + | len == 0 = empty | len == 1 = unsafeCreate size $ \destptr -> unsafeWithForeignPtr fp $ \p -> do byte <- peek p diff --git a/Data/ByteString/Lazy.hs b/Data/ByteString/Lazy.hs --- a/Data/ByteString/Lazy.hs +++ b/Data/ByteString/Lazy.hs @@ -849,7 +849,7 @@ in (Chunk c cs', cs'') --- | Similar to 'P.takeWhile', +-- | Similar to 'Prelude.takeWhile', -- returns the longest (possibly empty) prefix of elements -- satisfying the predicate. takeWhile :: (Word8 -> Bool) -> ByteString -> ByteString @@ -882,7 +882,7 @@ c' | S.length c' == S.length c -> (True, Chunk c bs) | otherwise -> (False, fromStrict c' `append` bs) --- | Similar to 'P.dropWhile', +-- | Similar to 'Prelude.dropWhile', -- drops the longest (possibly empty) prefix of elements -- satisfying the predicate and returns the remainder. dropWhile :: (Word8 -> Bool) -> ByteString -> ByteString @@ -893,7 +893,7 @@ n | n < S.length c -> Chunk (S.drop n c) cs | otherwise -> dropWhile' cs --- | Similar to 'P.dropWhileEnd', +-- | Similar to 'Prelude.dropWhileEnd', -- drops the longest (possibly empty) suffix of elements -- satisfying the predicate and returns the remainder. -- @@ -916,7 +916,7 @@ x' | S.null x' -> dropEndBytes xs | otherwise -> List.foldl' (flip Chunk) Empty (x' : xs) --- | Similar to 'P.break', +-- | Similar to 'Prelude.break', -- returns the longest (possibly empty) prefix of elements which __do not__ -- satisfy the predicate and the remainder of the string. -- @@ -995,7 +995,7 @@ | otherwise -> (x' : [], x'' : xs) -} --- | Similar to 'P.span', +-- | Similar to 'Prelude.span', -- returns the longest (possibly empty) prefix of elements -- satisfying the predicate and the remainder of the string. -- diff --git a/Data/ByteString/Lazy/Char8.hs b/Data/ByteString/Lazy/Char8.hs --- a/Data/ByteString/Lazy/Char8.hs +++ b/Data/ByteString/Lazy/Char8.hs @@ -885,12 +885,12 @@ let !c' = revChunks (B.unsafeTake n c : line) in c' : loop0 (B.unsafeDrop (n+1) c) cs --- | 'unlines' is an inverse operation to 'lines'. It joins lines, --- after appending a terminating newline to each. +-- | 'unlines' joins lines, appending a terminating newline after each. +-- +-- Equivalent to +-- @'concat' . Data.List.concatMap (\\x -> [x, 'singleton' \'\\n'])@. unlines :: [ByteString] -> ByteString -unlines [] = empty -unlines ss = concat (List.intersperse nl ss) `append` nl -- half as much space - where nl = singleton '\n' +unlines = List.foldr (\x t -> x `append` cons '\n' t) Empty -- | 'words' breaks a ByteString up into a list of words, which -- were delimited by Chars representing white space. And diff --git a/Data/ByteString/Short.hs b/Data/ByteString/Short.hs --- a/Data/ByteString/Short.hs +++ b/Data/ByteString/Short.hs @@ -2,10 +2,10 @@ -- | -- Module : Data.ByteString.Short --- Copyright : (c) Duncan Coutts 2012-2013 +-- Copyright : (c) Duncan Coutts 2012-2013, Julian Ospald 2022 -- License : BSD-style -- --- Maintainer : duncan@community.haskell.org +-- Maintainer : hasufell@posteo.de -- Stability : stable -- Portability : ghc only -- @@ -33,9 +33,9 @@ -- | With GHC, the memory overheads are as follows, expressed in words and -- in bytes (words are 4 and 8 bytes on 32 or 64bit machines respectively). -- - -- * 'B.ByteString' unshared: 9 words; 36 or 72 bytes. + -- * 'B.ByteString' unshared: 8 words; 32 or 64 bytes. -- - -- * 'B.ByteString' shared substring: 5 words; 20 or 40 bytes. + -- * 'B.ByteString' shared substring: 4 words; 16 or 32 bytes. -- -- * 'ShortByteString': 4 words; 16 or 32 bytes. -- @@ -67,23 +67,113 @@ -- small unpinned strings are allocated in the same way as normal heap -- allocations, rather than in a separate pinned area. - -- * Conversions - toShort, - fromShort, + -- * Introducing and eliminating 'ShortByteString's + empty, + singleton, pack, unpack, + fromShort, + toShort, - -- * Other operations - empty, null, length, index, indexMaybe, (!?), + -- * Basic interface + snoc, + cons, + append, + last, + tail, + uncons, + head, + init, + unsnoc, + null, + length, + -- * Encoding validation + isValidUtf8, + + -- * Transforming ShortByteStrings + map, + reverse, + intercalate, + + -- * Reducing 'ShortByteString's (folds) + foldl, + foldl', + foldl1, + foldl1', + + foldr, + foldr', + foldr1, + foldr1', + + -- ** Special folds + all, + any, + concat, + + -- ** Generating and unfolding ByteStrings + replicate, + unfoldr, + unfoldrN, + + -- * Substrings + + -- ** Breaking strings + take, + takeEnd, + takeWhileEnd, + takeWhile, + drop, + dropEnd, + dropWhile, + dropWhileEnd, + breakEnd, + break, + span, + spanEnd, + splitAt, + split, + splitWith, + stripSuffix, + stripPrefix, + + -- * Predicates + isInfixOf, + isPrefixOf, + isSuffixOf, + + -- ** Search for arbitrary substrings + breakSubstring, + + -- * Searching ShortByteStrings + + -- ** Searching by equality + elem, + + -- ** Searching with a predicate + find, + filter, + partition, + + -- * Indexing ShortByteStrings + index, + indexMaybe, + (!?), + elemIndex, + elemIndices, + count, + findIndex, + findIndices, + -- * Low level conversions -- ** Packing 'Foreign.C.String.CString's and pointers packCString, packCStringLen, - -- ** Using ByteStrings as 'Foreign.C.String.CString's + -- ** Using ShortByteStrings as 'Foreign.C.String.CString's useAsCString, - useAsCStringLen + useAsCStringLen, ) where import Data.ByteString.Short.Internal diff --git a/Data/ByteString/Short/Internal.hs b/Data/ByteString/Short/Internal.hs --- a/Data/ByteString/Short/Internal.hs +++ b/Data/ByteString/Short/Internal.hs @@ -1,610 +1,1862 @@ -{-# LANGUAGE DeriveDataTypeable, CPP, BangPatterns, RankNTypes, - ForeignFunctionInterface, MagicHash, UnboxedTuples, - UnliftedFFITypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# LANGUAGE Unsafe #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# OPTIONS_HADDOCK not-home #-} - --- | --- Module : Data.ByteString.Short.Internal --- Copyright : (c) Duncan Coutts 2012-2013 --- License : BSD-style --- --- Maintainer : duncan@community.haskell.org --- Stability : stable --- Portability : ghc only --- --- Internal representation of ShortByteString --- -module Data.ByteString.Short.Internal ( - - -- * The @ShortByteString@ type and representation - ShortByteString(..), - - -- * Conversions - toShort, - fromShort, - pack, - unpack, - - -- * Other operations - empty, null, length, index, indexMaybe, (!?), unsafeIndex, - - -- * Low level operations - createFromPtr, copyToPtr, - - -- * Low level conversions - -- ** Packing 'CString's and pointers - packCString, - packCStringLen, - - -- ** Using ByteStrings as 'CString's - useAsCString, - useAsCStringLen - ) where - -import Data.ByteString.Internal (ByteString(..), accursedUnutterablePerformIO) -import qualified Data.ByteString.Internal as BS - -import Data.Typeable (Typeable) -import Data.Data (Data(..), mkNoRepType) -import Data.Semigroup (Semigroup((<>))) -import Data.Monoid (Monoid(..)) -import Data.String (IsString(..)) -import Control.DeepSeq (NFData(..)) -import qualified Data.List as List (length) -import Foreign.C.String (CString, CStringLen) -import Foreign.C.Types (CSize(..), CInt(..)) -import Foreign.Marshal.Alloc (allocaBytes) -import Foreign.ForeignPtr (touchForeignPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import Foreign.Storable (pokeByteOff) - -import qualified GHC.Exts -import GHC.Exts ( Int(I#), Int#, Ptr(Ptr), Addr#, Char(C#) - , State#, RealWorld - , ByteArray#, MutableByteArray# - , newByteArray# - , newPinnedByteArray# - , byteArrayContents# - , unsafeCoerce# -#if MIN_VERSION_base(4,10,0) - , isByteArrayPinned# - , isTrue# -#endif - , sizeofByteArray# - , indexWord8Array#, indexCharArray# - , writeWord8Array#, writeCharArray# - , unsafeFreezeByteArray# ) -import GHC.IO -import GHC.ForeignPtr (ForeignPtr(ForeignPtr), ForeignPtrContents(PlainPtr)) -import GHC.ST (ST(ST), runST) -import GHC.Stack.Types (HasCallStack) -import GHC.Word - -import Prelude ( Eq(..), Ord(..), Ordering(..), Read(..), Show(..) - , ($), ($!), error, (++), (.) - , String, userError - , Bool(..), (&&), otherwise - , (+), (-), fromIntegral - , return - , Maybe(..) ) - -import qualified Language.Haskell.TH.Lib as TH -import qualified Language.Haskell.TH.Syntax as TH - --- | A compact representation of a 'Word8' vector. --- --- It has a lower memory overhead than a 'ByteString' and does not --- contribute to heap fragmentation. It can be converted to or from a --- 'ByteString' (at the cost of copying the string data). It supports very few --- other operations. --- --- It is suitable for use as an internal representation for code that needs --- to keep many short strings in memory, but it /should not/ be used as an --- interchange type. That is, it should not generally be used in public APIs. --- The 'ByteString' type is usually more suitable for use in interfaces; it is --- more flexible and it supports a wide range of operations. --- -data ShortByteString = SBS ByteArray# - deriving Typeable - --- | @since 0.11.2.0 -instance TH.Lift ShortByteString where -#if MIN_VERSION_template_haskell(2,16,0) - lift sbs = [| unsafePackLenLiteral |] - `TH.appE` TH.litE (TH.integerL (fromIntegral len)) - `TH.appE` TH.litE (TH.BytesPrimL $ TH.Bytes ptr 0 (fromIntegral len)) - where - BS ptr len = fromShort sbs -#else - lift sbs = [| unsafePackLenLiteral |] - `TH.appE` TH.litE (TH.integerL (fromIntegral len)) - `TH.appE` TH.litE (TH.StringPrimL $ BS.unpackBytes bs) - where - bs@(BS _ len) = fromShort sbs -#endif - -#if MIN_VERSION_template_haskell(2,17,0) - liftTyped = TH.unsafeCodeCoerce . TH.lift -#elif MIN_VERSION_template_haskell(2,16,0) - liftTyped = TH.unsafeTExpCoerce . TH.lift -#endif - --- The ByteArray# representation is always word sized and aligned but with a --- known byte length. Our representation choice for ShortByteString is to leave --- the 0--3 trailing bytes undefined. This means we can use word-sized writes, --- but we have to be careful with reads, see equateBytes and compareBytes below. - - -instance Eq ShortByteString where - (==) = equateBytes - -instance Ord ShortByteString where - compare = compareBytes - -instance Semigroup ShortByteString where - (<>) = append - -instance Monoid ShortByteString where - mempty = empty - mappend = (<>) - mconcat = concat - -instance NFData ShortByteString where - rnf SBS{} = () - -instance Show ShortByteString where - showsPrec p ps r = showsPrec p (unpackChars ps) r - -instance Read ShortByteString where - readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ] - --- | @since 0.10.12.0 -instance GHC.Exts.IsList ShortByteString where - type Item ShortByteString = Word8 - fromList = packBytes - toList = unpackBytes - --- | Beware: 'fromString' truncates multi-byte characters to octets. --- e.g. "枯朶に烏のとまりけり秋の暮" becomes �6k�nh~�Q��n� -instance IsString ShortByteString where - fromString = packChars - -instance Data ShortByteString where - gfoldl f z txt = z packBytes `f` unpackBytes txt - toConstr _ = error "Data.ByteString.Short.ShortByteString.toConstr" - gunfold _ _ = error "Data.ByteString.Short.ShortByteString.gunfold" - dataTypeOf _ = mkNoRepType "Data.ByteString.Short.ShortByteString" - ------------------------------------------------------------------------- --- Simple operations - --- | /O(1)/. The empty 'ShortByteString'. -empty :: ShortByteString -empty = create 0 (\_ -> return ()) - --- | /O(1)/ The length of a 'ShortByteString'. -length :: ShortByteString -> Int -length (SBS barr#) = I# (sizeofByteArray# barr#) - --- | /O(1)/ Test whether a 'ShortByteString' is empty. -null :: ShortByteString -> Bool -null sbs = length sbs == 0 - --- | /O(1)/ 'ShortByteString' index (subscript) operator, starting from 0. -index :: HasCallStack => ShortByteString -> Int -> Word8 -index sbs i - | i >= 0 && i < length sbs = unsafeIndex sbs i - | otherwise = indexError sbs i - --- | /O(1)/ 'ShortByteString' index, starting from 0, that returns 'Just' if: --- --- > 0 <= n < length bs --- --- @since 0.11.0.0 -indexMaybe :: ShortByteString -> Int -> Maybe Word8 -indexMaybe sbs i - | i >= 0 && i < length sbs = Just $! unsafeIndex sbs i - | otherwise = Nothing -{-# INLINE indexMaybe #-} - --- | /O(1)/ 'ShortByteString' index, starting from 0, that returns 'Just' if: --- --- > 0 <= n < length bs --- --- @since 0.11.0.0 -(!?) :: ShortByteString -> Int -> Maybe Word8 -(!?) = indexMaybe -{-# INLINE (!?) #-} - -unsafeIndex :: ShortByteString -> Int -> Word8 -unsafeIndex sbs = indexWord8Array (asBA sbs) - -indexError :: HasCallStack => ShortByteString -> Int -> a -indexError sbs i = - error $ "Data.ByteString.Short.index: error in array index; " ++ show i - ++ " not in range [0.." ++ show (length sbs) ++ ")" - --- | @since 0.11.2.0 -unsafePackLenLiteral :: Int -> Addr# -> ShortByteString -unsafePackLenLiteral len addr# = - accursedUnutterablePerformIO $ createFromPtr (Ptr addr#) len - ------------------------------------------------------------------------- --- Internal utils - -asBA :: ShortByteString -> BA -asBA (SBS ba#) = BA# ba# - -create :: Int -> (forall s. MBA s -> ST s ()) -> ShortByteString -create len fill = - runST $ do - mba <- newByteArray len - fill mba - BA# ba# <- unsafeFreezeByteArray mba - return (SBS ba#) -{-# INLINE create #-} - ------------------------------------------------------------------------- --- Conversion to and from ByteString - --- | /O(n)/. Convert a 'ByteString' into a 'ShortByteString'. --- --- This makes a copy, so does not retain the input string. --- -toShort :: ByteString -> ShortByteString -toShort !bs = unsafeDupablePerformIO (toShortIO bs) - -toShortIO :: ByteString -> IO ShortByteString -toShortIO (BS fptr len) = do - mba <- stToIO (newByteArray len) - let ptr = unsafeForeignPtrToPtr fptr - stToIO (copyAddrToByteArray ptr mba 0 len) - touchForeignPtr fptr - BA# ba# <- stToIO (unsafeFreezeByteArray mba) - return (SBS ba#) - - --- | /O(n)/. Convert a 'ShortByteString' into a 'ByteString'. --- -fromShort :: ShortByteString -> ByteString -#if MIN_VERSION_base(4,10,0) -fromShort (SBS b#) - | isTrue# (isByteArrayPinned# b#) = BS fp len - where - addr# = byteArrayContents# b# - fp = ForeignPtr addr# (PlainPtr (unsafeCoerce# b#)) - len = I# (sizeofByteArray# b#) -#endif -fromShort !sbs = unsafeDupablePerformIO (fromShortIO sbs) - -fromShortIO :: ShortByteString -> IO ByteString -fromShortIO sbs = do - let len = length sbs - mba@(MBA# mba#) <- stToIO (newPinnedByteArray len) - stToIO (copyByteArray (asBA sbs) 0 mba 0 len) - let fp = ForeignPtr (byteArrayContents# (unsafeCoerce# mba#)) - (PlainPtr mba#) - return (BS fp len) - - ------------------------------------------------------------------------- --- Packing and unpacking from lists - --- | /O(n)/. Convert a list into a 'ShortByteString' -pack :: [Word8] -> ShortByteString -pack = packBytes - --- | /O(n)/. Convert a 'ShortByteString' into a list. -unpack :: ShortByteString -> [Word8] -unpack = unpackBytes - -packChars :: [Char] -> ShortByteString -packChars cs = packLenChars (List.length cs) cs - -packBytes :: [Word8] -> ShortByteString -packBytes cs = packLenBytes (List.length cs) cs - -packLenChars :: Int -> [Char] -> ShortByteString -packLenChars len cs0 = - create len (\mba -> go mba 0 cs0) - where - go :: MBA s -> Int -> [Char] -> ST s () - go !_ !_ [] = return () - go !mba !i (c:cs) = do - writeCharArray mba i c - go mba (i+1) cs - -packLenBytes :: Int -> [Word8] -> ShortByteString -packLenBytes len ws0 = - create len (\mba -> go mba 0 ws0) - where - go :: MBA s -> Int -> [Word8] -> ST s () - go !_ !_ [] = return () - go !mba !i (w:ws) = do - writeWord8Array mba i w - go mba (i+1) ws - --- Unpacking bytestrings into lists effeciently is a tradeoff: on the one hand --- we would like to write a tight loop that just blats the list into memory, on --- the other hand we want it to be unpacked lazily so we don't end up with a --- massive list data structure in memory. --- --- Our strategy is to combine both: we will unpack lazily in reasonable sized --- chunks, where each chunk is unpacked strictly. --- --- unpackChars does the lazy loop, while unpackAppendBytes and --- unpackAppendChars do the chunks strictly. - -unpackChars :: ShortByteString -> [Char] -unpackChars bs = unpackAppendCharsLazy bs [] - -unpackBytes :: ShortByteString -> [Word8] -unpackBytes bs = unpackAppendBytesLazy bs [] - --- Why 100 bytes you ask? Because on a 64bit machine the list we allocate --- takes just shy of 4k which seems like a reasonable amount. --- (5 words per list element, 8 bytes per word, 100 elements = 4000 bytes) - -unpackAppendCharsLazy :: ShortByteString -> [Char] -> [Char] -unpackAppendCharsLazy sbs = go 0 (length sbs) - where - sz = 100 - - go off len cs - | len <= sz = unpackAppendCharsStrict sbs off len cs - | otherwise = unpackAppendCharsStrict sbs off sz remainder - where remainder = go (off+sz) (len-sz) cs - -unpackAppendBytesLazy :: ShortByteString -> [Word8] -> [Word8] -unpackAppendBytesLazy sbs = go 0 (length sbs) - where - sz = 100 - - go off len ws - | len <= sz = unpackAppendBytesStrict sbs off len ws - | otherwise = unpackAppendBytesStrict sbs off sz remainder - where remainder = go (off+sz) (len-sz) ws - --- For these unpack functions, since we're unpacking the whole list strictly we --- build up the result list in an accumulator. This means we have to build up --- the list starting at the end. So our traversal starts at the end of the --- buffer and loops down until we hit the sentinal: - -unpackAppendCharsStrict :: ShortByteString -> Int -> Int -> [Char] -> [Char] -unpackAppendCharsStrict !sbs off len = go (off-1) (off-1 + len) - where - go !sentinal !i !acc - | i == sentinal = acc - | otherwise = let !c = indexCharArray (asBA sbs) i - in go sentinal (i-1) (c:acc) - -unpackAppendBytesStrict :: ShortByteString -> Int -> Int -> [Word8] -> [Word8] -unpackAppendBytesStrict !sbs off len = go (off-1) (off-1 + len) - where - go !sentinal !i !acc - | i == sentinal = acc - | otherwise = let !w = indexWord8Array (asBA sbs) i - in go sentinal (i-1) (w:acc) - - ------------------------------------------------------------------------- --- Eq and Ord implementations - -equateBytes :: ShortByteString -> ShortByteString -> Bool -equateBytes sbs1 sbs2 = - let !len1 = length sbs1 - !len2 = length sbs2 - in len1 == len2 - && 0 == accursedUnutterablePerformIO - (memcmp_ByteArray (asBA sbs1) (asBA sbs2) len1) - -compareBytes :: ShortByteString -> ShortByteString -> Ordering -compareBytes sbs1 sbs2 = - let !len1 = length sbs1 - !len2 = length sbs2 - !len = min len1 len2 - in case accursedUnutterablePerformIO - (memcmp_ByteArray (asBA sbs1) (asBA sbs2) len) of - i | i < 0 -> LT - | i > 0 -> GT - | len2 > len1 -> LT - | len2 < len1 -> GT - | otherwise -> EQ - - ------------------------------------------------------------------------- --- Appending and concatenation - -append :: ShortByteString -> ShortByteString -> ShortByteString -append src1 src2 = - let !len1 = length src1 - !len2 = length src2 - in create (len1 + len2) $ \dst -> do - copyByteArray (asBA src1) 0 dst 0 len1 - copyByteArray (asBA src2) 0 dst len1 len2 - -concat :: [ShortByteString] -> ShortByteString -concat sbss = - create (totalLen 0 sbss) (\dst -> copy dst 0 sbss) - where - totalLen !acc [] = acc - totalLen !acc (sbs: sbss) = totalLen (acc + length sbs) sbss - - copy :: MBA s -> Int -> [ShortByteString] -> ST s () - copy !_ !_ [] = return () - copy !dst !off (src : sbss) = do - let !len = length src - copyByteArray (asBA src) 0 dst off len - copy dst (off + len) sbss - - ------------------------------------------------------------------------- --- Exported low level operations - -copyToPtr :: ShortByteString -- ^ source data - -> Int -- ^ offset into source - -> Ptr a -- ^ destination - -> Int -- ^ number of bytes to copy - -> IO () -copyToPtr src off dst len = - stToIO $ - copyByteArrayToAddr (asBA src) off dst len - -createFromPtr :: Ptr a -- ^ source data - -> Int -- ^ number of bytes to copy - -> IO ShortByteString -createFromPtr !ptr len = - stToIO $ do - mba <- newByteArray len - copyAddrToByteArray ptr mba 0 len - BA# ba# <- unsafeFreezeByteArray mba - return (SBS ba#) - - ------------------------------------------------------------------------- --- Primop wrappers - -data BA = BA# ByteArray# -data MBA s = MBA# (MutableByteArray# s) - -indexCharArray :: BA -> Int -> Char -indexCharArray (BA# ba#) (I# i#) = C# (indexCharArray# ba# i#) - -indexWord8Array :: BA -> Int -> Word8 -indexWord8Array (BA# ba#) (I# i#) = W8# (indexWord8Array# ba# i#) - -newByteArray :: Int -> ST s (MBA s) -newByteArray (I# len#) = - ST $ \s -> case newByteArray# len# s of - (# s, mba# #) -> (# s, MBA# mba# #) - -newPinnedByteArray :: Int -> ST s (MBA s) -newPinnedByteArray (I# len#) = - ST $ \s -> case newPinnedByteArray# len# s of - (# s, mba# #) -> (# s, MBA# mba# #) - -unsafeFreezeByteArray :: MBA s -> ST s BA -unsafeFreezeByteArray (MBA# mba#) = - ST $ \s -> case unsafeFreezeByteArray# mba# s of - (# s, ba# #) -> (# s, BA# ba# #) - -writeCharArray :: MBA s -> Int -> Char -> ST s () -writeCharArray (MBA# mba#) (I# i#) (C# c#) = - ST $ \s -> case writeCharArray# mba# i# c# s of - s -> (# s, () #) - -writeWord8Array :: MBA s -> Int -> Word8 -> ST s () -writeWord8Array (MBA# mba#) (I# i#) (W8# w#) = - ST $ \s -> case writeWord8Array# mba# i# w# s of - s -> (# s, () #) - -copyAddrToByteArray :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld () -copyAddrToByteArray (Ptr src#) (MBA# dst#) (I# dst_off#) (I# len#) = - ST $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of - s -> (# s, () #) - -copyByteArrayToAddr :: BA -> Int -> Ptr a -> Int -> ST RealWorld () -copyByteArrayToAddr (BA# src#) (I# src_off#) (Ptr dst#) (I# len#) = - ST $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of - s -> (# s, () #) - -copyByteArray :: BA -> Int -> MBA s -> Int -> Int -> ST s () -copyByteArray (BA# src#) (I# src_off#) (MBA# dst#) (I# dst_off#) (I# len#) = - ST $ \s -> case copyByteArray# src# src_off# dst# dst_off# len# s of - s -> (# s, () #) - - ------------------------------------------------------------------------- --- FFI imports - -memcmp_ByteArray :: BA -> BA -> Int -> IO CInt -memcmp_ByteArray (BA# ba1#) (BA# ba2#) len = - c_memcmp_ByteArray ba1# ba2# (fromIntegral len) - -foreign import ccall unsafe "string.h memcmp" - c_memcmp_ByteArray :: ByteArray# -> ByteArray# -> CSize -> IO CInt - - ------------------------------------------------------------------------- --- Primop replacements - -copyAddrToByteArray# :: Addr# - -> MutableByteArray# RealWorld -> Int# - -> Int# - -> State# RealWorld -> State# RealWorld - -copyByteArrayToAddr# :: ByteArray# -> Int# - -> Addr# - -> Int# - -> State# RealWorld -> State# RealWorld - -copyByteArray# :: ByteArray# -> Int# - -> MutableByteArray# s -> Int# - -> Int# - -> State# s -> State# s - -copyAddrToByteArray# = GHC.Exts.copyAddrToByteArray# -copyByteArrayToAddr# = GHC.Exts.copyByteArrayToAddr# -copyByteArray# = GHC.Exts.copyByteArray# - --- | /O(n)./ Construct a new @ShortByteString@ from a @CString@. The --- resulting @ShortByteString@ is an immutable copy of the original --- @CString@, and is managed on the Haskell heap. The original --- @CString@ must be null terminated. --- --- @since 0.10.10.0 -packCString :: CString -> IO ShortByteString -packCString cstr = do - len <- BS.c_strlen cstr - packCStringLen (cstr, fromIntegral len) - --- | /O(n)./ Construct a new @ShortByteString@ from a @CStringLen@. The --- resulting @ShortByteString@ is an immutable copy of the original @CStringLen@. --- The @ShortByteString@ is a normal Haskell value and will be managed on the --- Haskell heap. --- --- @since 0.10.10.0 -packCStringLen :: CStringLen -> IO ShortByteString -packCStringLen (cstr, len) | len >= 0 = createFromPtr cstr len -packCStringLen (_, len) = - moduleErrorIO "packCStringLen" ("negative length: " ++ show len) - --- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a --- null-terminated @CString@. The @CString@ is a copy and will be freed --- automatically; it must not be stored or used after the --- subcomputation finishes. --- --- @since 0.10.10.0 -useAsCString :: ShortByteString -> (CString -> IO a) -> IO a -useAsCString bs action = - allocaBytes (l+1) $ \buf -> do - copyToPtr bs 0 buf (fromIntegral l) - pokeByteOff buf l (0::Word8) - action buf - where l = length bs - --- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a @CStringLen@. --- As for @useAsCString@ this function makes a copy of the original @ShortByteString@. --- It must not be stored or used after the subcomputation finishes. --- --- @since 0.10.10.0 -useAsCStringLen :: ShortByteString -> (CStringLen -> IO a) -> IO a -useAsCStringLen bs action = - allocaBytes l $ \buf -> do - copyToPtr bs 0 buf (fromIntegral l) - action (buf, l) - where l = length bs - --- --------------------------------------------------------------------- --- Internal utilities - -moduleErrorIO :: HasCallStack => String -> String -> IO a -moduleErrorIO fun msg = throwIO . userError $ moduleErrorMsg fun msg -{-# NOINLINE moduleErrorIO #-} - -moduleErrorMsg :: String -> String -> String -moduleErrorMsg fun msg = "Data.ByteString.Short." ++ fun ++ ':':' ':msg +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE Unsafe #-} + +{-# OPTIONS_GHC -fno-warn-name-shadowing -fexpose-all-unfoldings #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- Not all architectures are forgiving of unaligned accesses; whitelist ones +-- which are known not to trap (either to the kernel for emulation, or crash). +#if defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH) \ + || ((defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)) \ + && defined(__ARM_FEATURE_UNALIGNED)) \ + || defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH) \ + || defined(powerpc64le_HOST_ARCH) +#define SAFE_UNALIGNED 1 +#endif + +-- | +-- Module : Data.ByteString.Short.Internal +-- Copyright : (c) Duncan Coutts 2012-2013, Julian Ospald 2022 +-- License : BSD-style +-- +-- Maintainer : hasufell@posteo.de +-- Stability : stable +-- Portability : ghc only +-- +-- Internal representation of ShortByteString +-- +module Data.ByteString.Short.Internal ( + + -- * The @ShortByteString@ type and representation + ShortByteString(..), + + -- * Introducing and eliminating 'ShortByteString's + empty, + singleton, + pack, + unpack, + fromShort, + toShort, + + -- * Basic interface + snoc, + cons, + append, + last, + tail, + uncons, + head, + init, + unsnoc, + null, + length, + + -- * Transforming ShortByteStrings + map, + reverse, + intercalate, + + -- * Reducing 'ShortByteString's (folds) + foldl, + foldl', + foldl1, + foldl1', + + foldr, + foldr', + foldr1, + foldr1', + + -- ** Special folds + all, + any, + concat, + + -- ** Generating and unfolding ByteStrings + replicate, + unfoldr, + unfoldrN, + + -- * Substrings + + -- ** Breaking strings + take, + takeEnd, + takeWhileEnd, + takeWhile, + drop, + dropEnd, + dropWhile, + dropWhileEnd, + breakEnd, + break, + span, + spanEnd, + splitAt, + split, + splitWith, + stripSuffix, + stripPrefix, + + -- * Predicates + isInfixOf, + isPrefixOf, + isSuffixOf, + + -- ** Search for arbitrary substrings + breakSubstring, + + -- * Searching ShortByteStrings + + -- ** Searching by equality + elem, + + -- ** Searching with a predicate + find, + filter, + partition, + + -- * Indexing ShortByteStrings + index, + indexMaybe, + (!?), + elemIndex, + elemIndices, + count, + findIndex, + findIndices, + + -- * Low level operations + createFromPtr, + copyToPtr, + + -- ** Encoding validation + isValidUtf8, + + -- * Low level conversions + -- ** Packing 'Foreign.C.String.CString's and pointers + packCString, + packCStringLen, + + -- ** Using ShortByteStrings as 'Foreign.C.String.CString's + useAsCString, + useAsCStringLen, + ) where + +import Data.ByteString.Internal + ( ByteString(..) + , accursedUnutterablePerformIO + , checkedAdd + ) + +import Data.Bits + ( FiniteBits (finiteBitSize) + , shiftL +#if MIN_VERSION_base(4,12,0) && defined(SAFE_UNALIGNED) + , shiftR +#endif + , (.&.) + , (.|.) + ) +import Data.Data + ( Data(..) + , mkNoRepType + ) +import Data.Monoid + ( Monoid(..) ) +import Data.Semigroup + ( Semigroup((<>)) ) +import Data.String + ( IsString(..) ) +import Data.Typeable + ( Typeable ) +import Control.Applicative + ( pure ) +import Control.DeepSeq + ( NFData(..) ) +import Control.Exception + ( assert ) +import Control.Monad + ( (>>) ) +import Foreign.C.String + ( CString + , CStringLen + ) +import Foreign.C.Types + ( CSize(..) + , CInt(..) + , CPtrdiff(..) + ) +import Foreign.ForeignPtr + ( touchForeignPtr ) +import Foreign.ForeignPtr.Unsafe + ( unsafeForeignPtrToPtr ) +import Foreign.Marshal.Alloc + ( allocaBytes ) +import Foreign.Storable + ( pokeByteOff ) +import GHC.Exts + ( Int(I#), Int#, Ptr(Ptr), Addr#, Char(C#) + , State#, RealWorld + , ByteArray#, MutableByteArray# + , newByteArray# + , newPinnedByteArray# + , byteArrayContents# + , unsafeCoerce# + , copyMutableByteArray# +#if MIN_VERSION_base(4,10,0) + , isByteArrayPinned# + , isTrue# +#endif +#if MIN_VERSION_base(4,11,0) + , compareByteArrays# +#endif + , sizeofByteArray# + , indexWord8Array#, indexCharArray# + , writeWord8Array# + , unsafeFreezeByteArray# +#if MIN_VERSION_base(4,12,0) && defined(SAFE_UNALIGNED) + ,writeWord64Array# + ,indexWord8ArrayAsWord64# +#endif + , setByteArray# + , sizeofByteArray# + , indexWord8Array#, indexCharArray# + , writeWord8Array# + , unsafeFreezeByteArray# + , touch# ) +import GHC.IO +import GHC.ForeignPtr + ( ForeignPtr(ForeignPtr) + , ForeignPtrContents(PlainPtr) + ) +import GHC.ST + ( ST(ST) + , runST + ) +import GHC.Stack.Types + ( HasCallStack ) +import GHC.Word +import Prelude + ( Eq(..), Ord(..), Ordering(..), Read(..), Show(..) + , ($), ($!), error, (++), (.), (||) + , String, userError + , Bool(..), (&&), otherwise + , (+), (-), fromIntegral + , (*) + , (^) + , (<$>) + , return + , Maybe(..) + , not + , snd + ) + +import qualified Data.ByteString.Internal as BS + +import qualified Data.Foldable as Foldable +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. +-- +-- It has a lower memory overhead than a 'ByteString' and does not +-- contribute to heap fragmentation. It can be converted to or from a +-- 'ByteString' (at the cost of copying the string data). It supports very few +-- other operations. +-- +-- It is suitable for use as an internal representation for code that needs +-- to keep many short strings in memory, but it /should not/ be used as an +-- interchange type. That is, it should not generally be used in public APIs. +-- The 'ByteString' type is usually more suitable for use in interfaces; it is +-- more flexible and it supports a wide range of operations. +-- +data ShortByteString = SBS ByteArray# + deriving Typeable + +-- | @since 0.11.2.0 +instance TH.Lift ShortByteString where +#if MIN_VERSION_template_haskell(2,16,0) + lift sbs = [| unsafePackLenLiteral |] + `TH.appE` TH.litE (TH.integerL (fromIntegral len)) + `TH.appE` TH.litE (TH.BytesPrimL $ TH.Bytes ptr 0 (fromIntegral len)) + where + BS ptr len = fromShort sbs +#else + lift sbs = [| unsafePackLenLiteral |] + `TH.appE` TH.litE (TH.integerL (fromIntegral len)) + `TH.appE` TH.litE (TH.StringPrimL $ BS.unpackBytes bs) + where + bs@(BS _ len) = fromShort sbs +#endif + +#if MIN_VERSION_template_haskell(2,17,0) + liftTyped = TH.unsafeCodeCoerce . TH.lift +#elif MIN_VERSION_template_haskell(2,16,0) + liftTyped = TH.unsafeTExpCoerce . TH.lift +#endif + +-- The ByteArray# representation is always word sized and aligned but with a +-- known byte length. Our representation choice for ShortByteString is to leave +-- the 0--3 trailing bytes undefined. This means we can use word-sized writes, +-- but we have to be careful with reads, see equateBytes and compareBytes below. + + +instance Eq ShortByteString where + (==) = equateBytes + +instance Ord ShortByteString where + compare = compareBytes + +instance Semigroup ShortByteString where + (<>) = append + +instance Monoid ShortByteString where + mempty = empty + mappend = (<>) + mconcat = concat + +instance NFData ShortByteString where + rnf SBS{} = () + +instance Show ShortByteString where + showsPrec p ps r = showsPrec p (unpackChars ps) r + +instance Read ShortByteString where + readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ] + +-- | @since 0.10.12.0 +instance GHC.Exts.IsList ShortByteString where + type Item ShortByteString = Word8 + fromList = packBytes + toList = unpackBytes + +-- | Beware: 'fromString' truncates multi-byte characters to octets. +-- e.g. "枯朶に烏のとまりけり秋の暮" becomes �6k�nh~�Q��n� +instance IsString ShortByteString where + fromString = packChars + +instance Data ShortByteString where + gfoldl f z txt = z packBytes `f` unpackBytes txt + toConstr _ = error "Data.ByteString.Short.ShortByteString.toConstr" + gunfold _ _ = error "Data.ByteString.Short.ShortByteString.gunfold" + dataTypeOf _ = mkNoRepType "Data.ByteString.Short.ShortByteString" + +------------------------------------------------------------------------ +-- Simple operations + +-- | /O(1)/. The empty 'ShortByteString'. +empty :: ShortByteString +empty = create 0 (\_ -> return ()) + +-- | /O(1)/ The length of a 'ShortByteString'. +length :: ShortByteString -> Int +length (SBS barr#) = I# (sizeofByteArray# barr#) + +-- | /O(1)/ Test whether a 'ShortByteString' is empty. +null :: ShortByteString -> Bool +null sbs = length sbs == 0 + +-- | /O(1)/ 'ShortByteString' index (subscript) operator, starting from 0. +index :: HasCallStack => ShortByteString -> Int -> Word8 +index sbs i + | i >= 0 && i < length sbs = unsafeIndex sbs i + | otherwise = indexError sbs i + +-- | /O(1)/ 'ShortByteString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 0.11.0.0 +indexMaybe :: ShortByteString -> Int -> Maybe Word8 +indexMaybe sbs i + | i >= 0 && i < length sbs = Just $! unsafeIndex sbs i + | otherwise = Nothing +{-# INLINE indexMaybe #-} + +-- | /O(1)/ 'ShortByteString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 0.11.0.0 +(!?) :: ShortByteString -> Int -> Maybe Word8 +(!?) = indexMaybe +{-# INLINE (!?) #-} + +unsafeIndex :: ShortByteString -> Int -> Word8 +unsafeIndex sbs = indexWord8Array (asBA sbs) + +indexError :: HasCallStack => ShortByteString -> Int -> a +indexError sbs i = + moduleError "index" $ "error in array index: " ++ show i + ++ " not in range [0.." ++ show (length sbs) ++ "]" + +-- | @since 0.11.2.0 +unsafePackLenLiteral :: Int -> Addr# -> ShortByteString +unsafePackLenLiteral len addr# = + accursedUnutterablePerformIO $ createFromPtr (Ptr addr#) len + +------------------------------------------------------------------------ +-- Internal utils + +asBA :: ShortByteString -> BA +asBA (SBS ba#) = BA# ba# + +create :: Int -> (forall s. MBA s -> ST s ()) -> ShortByteString +create len fill = + runST $ do + mba <- newByteArray len + fill mba + BA# ba# <- unsafeFreezeByteArray mba + return (SBS ba#) +{-# INLINE create #-} + +-- | Given the maximum size needed and a function to make the contents +-- of a ShortByteString, createAndTrim makes the 'ShortByteString'. +-- The generating function is required to return the actual final size +-- (<= the maximum size) and the result value. The resulting byte array +-- is realloced to this size. +createAndTrim :: Int -> (forall s. 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 + then do + BA# ba# <- unsafeFreezeByteArray mba + return (SBS ba#, res) + else do + mba2 <- newByteArray l' + copyMutableByteArray mba 0 mba2 0 l' + 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 + then do + BA# ba# <- unsafeFreezeByteArray mba + return (SBS ba#) + else do + mba2 <- newByteArray l' + copyMutableByteArray mba 0 mba2 0 l' + 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 = + runST $ do + mba1 <- newByteArray l + mba2 <- newByteArray l + (l1, l2) <- fill mba1 mba2 + sbs1 <- freeze' l1 mba1 + sbs2 <- freeze' l2 mba2 + pure (sbs1, sbs2) + where + freeze' :: Int -> MBA s -> ST s ShortByteString + freeze' l' mba = + if assert (l' <= l) $ l' >= l + then do + BA# ba# <- unsafeFreezeByteArray mba + return (SBS ba#) + else do + mba2 <- newByteArray l' + copyMutableByteArray mba 0 mba2 0 l' + BA# ba# <- unsafeFreezeByteArray mba2 + return (SBS ba#) +{-# INLINE createAndTrim'' #-} + +isPinned :: ByteArray# -> Bool +#if MIN_VERSION_base(4,10,0) +isPinned ba# = isTrue# (isByteArrayPinned# ba#) +#else +isPinned _ = False +#endif + +------------------------------------------------------------------------ +-- Conversion to and from ByteString + +-- | /O(n)/. Convert a 'ByteString' into a 'ShortByteString'. +-- +-- This makes a copy, so does not retain the input string. +-- +toShort :: ByteString -> ShortByteString +toShort !bs = unsafeDupablePerformIO (toShortIO bs) + +toShortIO :: ByteString -> IO ShortByteString +toShortIO (BS fptr len) = do + mba <- stToIO (newByteArray len) + let ptr = unsafeForeignPtrToPtr fptr + stToIO (copyAddrToByteArray ptr mba 0 len) + touchForeignPtr fptr + BA# ba# <- stToIO (unsafeFreezeByteArray mba) + return (SBS ba#) + +-- | /O(n)/. Convert a 'ShortByteString' into a 'ByteString'. +-- +fromShort :: ShortByteString -> ByteString +fromShort (SBS b#) + | isPinned b# = BS fp len + where + addr# = byteArrayContents# b# + fp = ForeignPtr addr# (PlainPtr (unsafeCoerce# b#)) + len = I# (sizeofByteArray# b#) +fromShort !sbs = unsafeDupablePerformIO (fromShortIO sbs) + +fromShortIO :: ShortByteString -> IO ByteString +fromShortIO sbs = do + let len = length sbs + mba@(MBA# mba#) <- stToIO (newPinnedByteArray len) + stToIO (copyByteArray (asBA sbs) 0 mba 0 len) + let fp = ForeignPtr (byteArrayContents# (unsafeCoerce# mba#)) + (PlainPtr mba#) + return (BS fp len) + +-- | /O(1)/ Convert a 'Word8' into a 'ShortByteString' +-- +-- @since 0.11.3.0 +singleton :: Word8 -> ShortByteString +singleton = \w -> create 1 (\mba -> writeWord8Array mba 0 w) + +------------------------------------------------------------------------ +-- Packing and unpacking from lists + +-- | /O(n)/. Convert a list into a 'ShortByteString' +pack :: [Word8] -> ShortByteString +pack = packBytes + +-- | /O(n)/. Convert a 'ShortByteString' into a list. +unpack :: ShortByteString -> [Word8] +unpack = unpackBytes + +packChars :: [Char] -> ShortByteString +packChars = \cs -> packLenBytes (List.length cs) (List.map BS.c2w cs) + +packBytes :: [Word8] -> ShortByteString +packBytes = \ws -> packLenBytes (List.length ws) ws + +packLenBytes :: Int -> [Word8] -> ShortByteString +packLenBytes len ws0 = + create len (\mba -> go mba 0 ws0) + where + go :: MBA s -> Int -> [Word8] -> ST s () + go !_ !_ [] = return () + go !mba !i (w:ws) = do + writeWord8Array mba i w + go mba (i+1) ws + +-- Unpacking bytestrings into lists effeciently is a tradeoff: on the one hand +-- we would like to write a tight loop that just blats the list into memory, on +-- the other hand we want it to be unpacked lazily so we don't end up with a +-- massive list data structure in memory. +-- +-- Our strategy is to combine both: we will unpack lazily in reasonable sized +-- chunks, where each chunk is unpacked strictly. +-- +-- unpackChars does the lazy loop, while unpackAppendBytes and +-- unpackAppendChars do the chunks strictly. + +unpackChars :: ShortByteString -> [Char] +unpackChars sbs = unpackAppendCharsLazy sbs [] + +unpackBytes :: ShortByteString -> [Word8] +unpackBytes sbs = unpackAppendBytesLazy sbs [] + +-- Why 100 bytes you ask? Because on a 64bit machine the list we allocate +-- takes just shy of 4k which seems like a reasonable amount. +-- (5 words per list element, 8 bytes per word, 100 elements = 4000 bytes) + +unpackAppendCharsLazy :: ShortByteString -> [Char] -> [Char] +unpackAppendCharsLazy sbs = go 0 (length sbs) + where + sz = 100 + + go off len cs + | len <= sz = unpackAppendCharsStrict sbs off len cs + | otherwise = unpackAppendCharsStrict sbs off sz remainder + where remainder = go (off+sz) (len-sz) cs + +unpackAppendBytesLazy :: ShortByteString -> [Word8] -> [Word8] +unpackAppendBytesLazy sbs = go 0 (length sbs) + where + sz = 100 + + go off len ws + | len <= sz = unpackAppendBytesStrict sbs off len ws + | otherwise = unpackAppendBytesStrict sbs off sz remainder + where remainder = go (off+sz) (len-sz) ws + +-- For these unpack functions, since we're unpacking the whole list strictly we +-- build up the result list in an accumulator. This means we have to build up +-- the list starting at the end. So our traversal starts at the end of the +-- buffer and loops down until we hit the sentinal: + +unpackAppendCharsStrict :: ShortByteString -> Int -> Int -> [Char] -> [Char] +unpackAppendCharsStrict !sbs off len = go (off-1) (off-1 + len) + where + go !sentinal !i !acc + | i == sentinal = acc + | otherwise = let !c = indexCharArray (asBA sbs) i + in go sentinal (i-1) (c:acc) + +unpackAppendBytesStrict :: ShortByteString -> Int -> Int -> [Word8] -> [Word8] +unpackAppendBytesStrict !sbs off len = go (off-1) (off-1 + len) + where + go !sentinal !i !acc + | i == sentinal = acc + | otherwise = let !w = indexWord8Array (asBA sbs) i + in go sentinal (i-1) (w:acc) + + +------------------------------------------------------------------------ +-- Eq and Ord implementations + +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 + !len2 = length sbs2 + !len = min len1 len2 + in case compareByteArrays (asBA sbs1) (asBA sbs2) len of + i | i < 0 -> LT + | i > 0 -> GT + | len2 > len1 -> LT + | len2 < len1 -> GT + | otherwise -> EQ + + +------------------------------------------------------------------------ +-- Appending and concatenation + +append :: ShortByteString -> ShortByteString -> ShortByteString +append src1 src2 = + let !len1 = length src1 + !len2 = length src2 + in create (len1 + len2) $ \dst -> do + copyByteArray (asBA src1) 0 dst 0 len1 + copyByteArray (asBA src2) 0 dst len1 len2 + +concat :: [ShortByteString] -> ShortByteString +concat = \sbss -> + create (totalLen 0 sbss) (\dst -> copy dst 0 sbss) + where + totalLen !acc [] = acc + totalLen !acc (sbs: sbss) = totalLen (acc + length sbs) sbss + + copy :: MBA s -> Int -> [ShortByteString] -> ST s () + copy !_ !_ [] = return () + copy !dst !off (src : sbss) = do + let !len = length src + copyByteArray (asBA src) 0 dst off len + copy dst (off + len) sbss + +-- --------------------------------------------------------------------- +-- Basic interface + +infixr 5 `cons` --same as list (:) +infixl 5 `snoc` + +-- | /O(n)/ Append a byte to the end of a 'ShortByteString' +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +snoc :: ShortByteString -> Word8 -> ShortByteString +snoc = \sbs c -> let l = length sbs + nl = l + 1 + in create nl $ \mba -> do + copyByteArray (asBA sbs) 0 mba 0 l + writeWord8Array mba l c + +-- | /O(n)/ 'cons' is analogous to (:) for lists. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +cons :: Word8 -> ShortByteString -> ShortByteString +cons c = \sbs -> let l = length sbs + nl = l + 1 + in create nl $ \mba -> do + writeWord8Array mba 0 c + copyByteArray (asBA sbs) 0 mba 1 l + +-- | /O(1)/ Extract the last element of a ShortByteString, which must be finite and non-empty. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- This is a partial function, consider using 'unsnoc' instead. +-- +-- @since 0.11.3.0 +last :: HasCallStack => ShortByteString -> Word8 +last = \sbs -> case null sbs of + True -> errorEmptySBS "last" + False -> indexWord8Array (asBA sbs) (length sbs - 1) + +-- | /O(n)/ Extract the elements after the head of a ShortByteString, which must be non-empty. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- This is a partial function, consider using 'uncons' instead. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +tail :: HasCallStack => ShortByteString -> ShortByteString +tail = \sbs -> + let l = length sbs + nl = l - 1 + in case null sbs of + True -> errorEmptySBS "tail" + False -> create nl $ \mba -> copyByteArray (asBA sbs) 1 mba 0 nl + +-- | /O(n)/ Extract the head and tail of a ByteString, returning Nothing +-- if it is empty. +-- +-- @since 0.11.3.0 +uncons :: ShortByteString -> Maybe (Word8, ShortByteString) +uncons = \sbs -> + let l = length sbs + nl = l - 1 + in if | l <= 0 -> Nothing + | otherwise -> let h = indexWord8Array (asBA sbs) 0 + t = create nl $ \mba -> copyByteArray (asBA sbs) 1 mba 0 nl + in Just (h, t) + +-- | /O(1)/ Extract the first element of a ShortByteString, which must be non-empty. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- This is a partial function, consider using 'uncons' instead. +-- +-- @since 0.11.3.0 +head :: HasCallStack => ShortByteString -> Word8 +head = \sbs -> case null sbs of + True -> errorEmptySBS "head" + False -> indexWord8Array (asBA sbs) 0 + +-- | /O(n)/ Return all the elements of a 'ShortByteString' except the last one. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- This is a partial function, consider using 'unsnoc' instead. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +init :: HasCallStack => ShortByteString -> ShortByteString +init = \sbs -> + let l = length sbs + nl = l - 1 + in case null sbs of + True -> errorEmptySBS "init" + False -> create nl $ \mba -> copyByteArray (asBA sbs) 0 mba 0 nl + +-- | /O(n)/ Extract the 'init' and 'last' of a ByteString, returning Nothing +-- if it is empty. +-- +-- @since 0.11.3.0 +unsnoc :: ShortByteString -> Maybe (ShortByteString, Word8) +unsnoc = \sbs -> + let l = length sbs + nl = l - 1 + in if | l <= 0 -> Nothing + | otherwise -> let l' = indexWord8Array (asBA sbs) (l - 1) + i = create nl $ \mba -> copyByteArray (asBA sbs) 0 mba 0 nl + in Just (i, l') + + +-- --------------------------------------------------------------------- +-- Transformations + +-- | /O(n)/ 'map' @f xs@ is the ShortByteString obtained by applying @f@ to each +-- element of @xs@. +-- +-- @since 0.11.3.0 +map :: (Word8 -> Word8) -> ShortByteString -> ShortByteString +map f = \sbs -> + let l = length sbs + ba = asBA sbs + in create l (\mba -> go ba mba 0 l) + where + go :: BA -> MBA s -> Int -> Int -> ST s () + go !ba !mba !i !l + | i >= l = return () + | otherwise = do + let w = indexWord8Array ba i + writeWord8Array mba i (f w) + go ba mba (i+1) l + + +-- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order. +-- +-- @since 0.11.3.0 +reverse :: ShortByteString -> ShortByteString +reverse = \sbs -> + let l = length sbs + ba = asBA sbs +-- https://gitlab.haskell.org/ghc/ghc/-/issues/21015 +#if MIN_VERSION_base(4,12,0) && defined(SAFE_UNALIGNED) + in create l (\mba -> go ba mba l) + where + go :: forall s. BA -> MBA s -> Int -> ST s () + go !ba !mba !l = do + -- this is equivalent to: (q, r) = l `quotRem` 8 + let q = l `shiftR` 3 + r = l .&. 7 + i' <- goWord8Chunk 0 r + goWord64Chunk i' 0 q + where + + goWord64Chunk :: Int -> Int -> Int -> ST s () + goWord64Chunk !off !i' !cl = loop i' + where + loop :: Int -> ST s () + loop !i + | i >= cl = return () + | otherwise = do + let w = indexWord8ArrayAsWord64 ba (off + (i * 8)) + writeWord64Array mba (cl - 1 - i) (byteSwap64 w) + loop (i+1) + + goWord8Chunk :: Int -> Int -> ST s Int + goWord8Chunk !i' !cl = loop i' + where + loop :: Int -> ST s Int + loop !i + | i >= cl = return i + | otherwise = do + let w = indexWord8Array ba i + writeWord8Array mba (l - 1 - i) w + loop (i+1) +#else + in create l (\mba -> go ba mba 0 l) + where + go :: BA -> MBA s -> Int -> Int -> ST s () + go !ba !mba !i !l + | i >= l = return () + | otherwise = do + let w = indexWord8Array ba i + writeWord8Array mba (l - 1 - i) w + go ba mba (i+1) l +#endif + + +-- | /O(n)/ The 'intercalate' function takes a 'ShortByteString' and a list of +-- 'ShortByteString's and concatenates the list after interspersing the first +-- argument between each element of the list. +-- +-- @since 0.11.3.0 +intercalate :: ShortByteString -> [ShortByteString] -> ShortByteString +intercalate sep = \case + [] -> empty + [x] -> x -- This branch exists for laziness, not speed + (sbs:t) -> let !totalLen = List.foldl' (\acc chunk -> acc +! length sep +! length chunk) (length sbs) t + in create totalLen (\mba -> + let !l = length sbs + in copyByteArray (asBA sbs) 0 mba 0 l >> go mba l t) + where + ba = asBA sep + lba = length sep + + go :: MBA s -> Int -> [ShortByteString] -> ST s () + go _ _ [] = pure () + go mba !off (chunk:chunks) = do + let lc = length chunk + copyByteArray ba 0 mba off lba + copyByteArray (asBA chunk) 0 mba (off + lba) lc + go mba (off + lc + lba) chunks + (+!) = checkedAdd "Short.intercalate" + + +-- --------------------------------------------------------------------- +-- Reducing 'ByteString's + +-- | 'foldl', applied to a binary operator, a starting value (typically +-- the left-identity of the operator), and a ShortByteString, reduces the +-- ShortByteString using the binary operator, from left to right. +-- +-- @since 0.11.3.0 +foldl :: (a -> Word8 -> a) -> a -> ShortByteString -> a +foldl f v = List.foldl f v . unpack + +-- | 'foldl'' is like 'foldl', but strict in the accumulator. +-- +-- @since 0.11.3.0 +foldl' :: (a -> Word8 -> a) -> a -> ShortByteString -> a +foldl' f v = List.foldl' f v . unpack + +-- | 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a ShortByteString, +-- reduces the ShortByteString using the binary operator, from right to left. +-- +-- @since 0.11.3.0 +foldr :: (Word8 -> a -> a) -> a -> ShortByteString -> a +foldr f v = List.foldr f v . unpack + +-- | 'foldr'' is like 'foldr', but strict in the accumulator. +-- +-- @since 0.11.3.0 +foldr' :: (Word8 -> a -> a) -> a -> ShortByteString -> a +foldr' k v = Foldable.foldr' k v . unpack + +-- | 'foldl1' is a variant of 'foldl' that has no starting value +-- argument, and thus must be applied to non-empty 'ShortByteString's. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- @since 0.11.3.0 +foldl1 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ShortByteString -> Word8 +foldl1 k = List.foldl1 k . unpack + +-- | 'foldl1'' is like 'foldl1', but strict in the accumulator. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- @since 0.11.3.0 +foldl1' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ShortByteString -> Word8 +foldl1' k = List.foldl1' k . unpack + +-- | 'foldr1' is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty 'ShortByteString's +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- @since 0.11.3.0 +foldr1 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ShortByteString -> Word8 +foldr1 k = List.foldr1 k . unpack + +-- | 'foldr1'' is a variant of 'foldr1', but is strict in the +-- accumulator. +-- +-- @since 0.11.3.0 +foldr1' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ShortByteString -> Word8 +foldr1' k = \sbs -> if null sbs then errorEmptySBS "foldr1'" else foldr' k (last sbs) (init sbs) + + + +-- --------------------------------------------------------------------- +-- Special folds + +-- | /O(n)/ Applied to a predicate and a 'ShortByteString', 'all' determines +-- if all elements of the 'ShortByteString' satisfy the predicate. +-- +-- @since 0.11.3.0 +all :: (Word8 -> Bool) -> ShortByteString -> Bool +all k = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = True + | otherwise = k (w n) && go (n + 1) + in go 0 + + +-- | /O(n)/ Applied to a predicate and a ByteString, 'any' determines if +-- any element of the 'ByteString' satisfies the predicate. +-- +-- @since 0.11.3.0 +any :: (Word8 -> Bool) -> ShortByteString -> Bool +any k = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = False + | otherwise = k (w n) || go (n + 1) + in go 0 + + + +-- --------------------------------------------------------------------- +-- Substrings + +-- | /O(n)/ 'take' @n@, applied to a ShortByteString @xs@, returns the prefix +-- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +take :: Int -> ShortByteString -> ShortByteString +take = \n -> \sbs -> let sl = length sbs + in if | n >= sl -> sbs + | n <= 0 -> empty + | otherwise -> + create n $ \mba -> copyByteArray (asBA sbs) 0 mba 0 n + +-- | Similar to 'Prelude.takeWhile', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate. +-- +-- @since 0.11.3.0 +takeWhile :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +takeWhile f = \sbs -> take (findIndexOrLength (not . f) sbs) sbs + +-- | /O(n)/ @'takeEnd' n xs@ is equivalent to @'drop' ('length' xs - n) xs@. +-- Takes @n@ elements from end of bytestring. +-- +-- >>> takeEnd 3 "abcdefg" +-- "efg" +-- >>> takeEnd 0 "abcdefg" +-- "" +-- >>> takeEnd 4 "abc" +-- "abc" +-- +-- @since 0.11.3.0 +takeEnd :: Int -> ShortByteString -> ShortByteString +takeEnd n = \sbs -> let sl = length sbs + in if | n >= sl -> sbs + | n <= 0 -> empty + | otherwise -> create n $ \mba -> copyByteArray (asBA sbs) (max 0 (sl - n)) mba 0 n + + +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate. +-- +-- @'takeWhileEnd' p@ is equivalent to @'reverse' . 'takeWhile' p . 'reverse'@. +-- +-- @since 0.11.3.0 +takeWhileEnd :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +takeWhileEnd f = \sbs -> drop (findFromEndUntil (not . f) sbs) sbs + +-- | /O(n)/ 'drop' @n@ @xs@ returns the suffix of @xs@ after the first n elements, or @[]@ if @n > 'length' xs@. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +drop :: Int -> ShortByteString -> ShortByteString +drop = \n -> \sbs -> + let len = length sbs + in if | n <= 0 -> sbs + | n >= len -> empty + | otherwise -> + let newLen = len - n + in create newLen $ \mba -> copyByteArray (asBA sbs) n mba 0 newLen + +-- | /O(n)/ @'dropEnd' n xs@ is equivalent to @'take' ('length' xs - n) xs@. +-- Drops @n@ elements from end of bytestring. +-- +-- >>> dropEnd 3 "abcdefg" +-- "abcd" +-- >>> dropEnd 0 "abcdefg" +-- "abcdefg" +-- >>> dropEnd 4 "abc" +-- "" +-- +-- @since 0.11.3.0 +dropEnd :: Int -> ShortByteString -> ShortByteString +dropEnd n = \sbs -> let sl = length sbs + nl = sl - n + in if | n >= sl -> empty + | n <= 0 -> sbs + | otherwise -> create nl $ \mba -> copyByteArray (asBA sbs) 0 mba 0 nl + +-- | Similar to 'Prelude.dropWhile', +-- drops the longest (possibly empty) prefix of elements +-- satisfying the predicate and returns the remainder. +-- +-- Note: copies the entire byte array +-- +-- @since 0.11.3.0 +dropWhile :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +dropWhile f = \sbs -> drop (findIndexOrLength (not . f) sbs) sbs + +-- | Similar to 'Prelude.dropWhileEnd', +-- drops the longest (possibly empty) suffix of elements +-- satisfying the predicate and returns the remainder. +-- +-- @'dropWhileEnd' p@ is equivalent to @'reverse' . 'dropWhile' p . 'reverse'@. +-- +-- @since 0.11.3.0 +dropWhileEnd :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +dropWhileEnd f = \sbs -> take (findFromEndUntil (not . f) sbs) sbs + +-- | Returns the longest (possibly empty) suffix of elements which __do not__ +-- satisfy the predicate and the remainder of the string. +-- +-- 'breakEnd' @p@ is equivalent to @'spanEnd' (not . p)@ and to @('takeWhileEnd' (not . p) &&& 'dropWhileEnd' (not . p))@. +-- +-- @since 0.11.3.0 +breakEnd :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +breakEnd p = \sbs -> splitAt (findFromEndUntil p sbs) sbs + +-- | Similar to 'Prelude.break', +-- returns the longest (possibly empty) prefix of elements which __do not__ +-- satisfy the predicate and the remainder of the string. +-- +-- 'break' @p@ is equivalent to @'span' (not . p)@ and to @('takeWhile' (not . p) &&& 'dropWhile' (not . p))@. +-- +-- @since 0.11.3.0 +break :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +break = \p -> \sbs -> case findIndexOrLength p sbs of n -> (take n sbs, drop n sbs) + +-- | Similar to 'Prelude.span', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate and the remainder of the string. +-- +-- 'span' @p@ is equivalent to @'break' (not . p)@ and to @('takeWhile' p &&& 'dropWhile' p)@. +-- +-- @since 0.11.3.0 +span :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +span p = break (not . p) + +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate and the remainder of the string. +-- +-- 'spanEnd' @p@ is equivalent to @'breakEnd' (not . p)@ and to @('takeWhileEnd' p &&& 'dropWhileEnd' p)@. +-- +-- We have +-- +-- > spanEnd (not . isSpace) "x y z" == ("x y ", "z") +-- +-- and +-- +-- > spanEnd (not . isSpace) sbs +-- > == +-- > let (x, y) = span (not . isSpace) (reverse sbs) in (reverse y, reverse x) +-- +-- @since 0.11.3.0 +spanEnd :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +spanEnd p = \sbs -> splitAt (findFromEndUntil (not . p) sbs) sbs + +-- | /O(n)/ 'splitAt' @n sbs@ is equivalent to @('take' n sbs, 'drop' n sbs)@. +-- +-- Note: copies the substrings +-- +-- @since 0.11.3.0 +splitAt :: Int -> ShortByteString -> (ShortByteString, ShortByteString) +splitAt n = \sbs -> if + | n <= 0 -> (empty, sbs) + | otherwise -> + let slen = length sbs + in if | n >= length sbs -> (sbs, empty) + | otherwise -> + let llen = min slen (max 0 n) + rlen = max 0 (slen - max 0 n) + lsbs = create llen $ \mba -> copyByteArray (asBA sbs) 0 mba 0 llen + rsbs = create rlen $ \mba -> copyByteArray (asBA sbs) n mba 0 rlen + in (lsbs, rsbs) + +-- | /O(n)/ Break a 'ShortByteString' into pieces separated by the byte +-- argument, consuming the delimiter. I.e. +-- +-- > split 10 "a\nb\nd\ne" == ["a","b","d","e"] -- fromEnum '\n' == 10 +-- > split 97 "aXaXaXa" == ["","X","X","X",""] -- fromEnum 'a' == 97 +-- > split 120 "x" == ["",""] -- fromEnum 'x' == 120 +-- > split undefined "" == [] -- and not [""] +-- +-- and +-- +-- > intercalate [c] . split c == id +-- > split == splitWith . (==) +-- +-- Note: copies the substrings +-- +-- @since 0.11.3.0 +split :: Word8 -> ShortByteString -> [ShortByteString] +split w = splitWith (== w) + + +-- | /O(n)/ Splits a 'ShortByteString' into components delimited by +-- separators, where the predicate returns True for a separator element. +-- The resulting components do not contain the separators. Two adjacent +-- separators result in an empty component in the output. eg. +-- +-- > splitWith (==97) "aabbaca" == ["","","bb","c",""] -- fromEnum 'a' == 97 +-- > splitWith undefined "" == [] -- and not [""] +-- +-- @since 0.11.3.0 +splitWith :: (Word8 -> Bool) -> ShortByteString -> [ShortByteString] +splitWith p = \sbs -> if + | null sbs -> [] + | otherwise -> go sbs + where + go sbs' + | null sbs' = [empty] + | otherwise = + case break p sbs' of + (a, b) + | null b -> [a] + | otherwise -> a : go (tail b) + + +-- | /O(n)/ The 'stripSuffix' function takes two ShortByteStrings and returns 'Just' +-- the remainder of the second iff the first is its suffix, and otherwise +-- 'Nothing'. +-- +-- @since 0.11.3.0 +stripSuffix :: ShortByteString -> ShortByteString -> Maybe ShortByteString +stripSuffix sbs1 = \sbs2 -> do + let l1 = length sbs1 + l2 = length sbs2 + if | isSuffixOf sbs1 sbs2 -> + if null sbs1 + then Just sbs2 + else Just $! create (l2 - l1) $ \dst -> do + copyByteArray (asBA sbs2) 0 dst 0 (l2 - l1) + | otherwise -> Nothing + +-- | /O(n)/ The 'stripPrefix' function takes two ShortByteStrings and returns 'Just' +-- the remainder of the second iff the first is its prefix, and otherwise +-- 'Nothing'. +-- +-- @since 0.11.3.0 +stripPrefix :: ShortByteString -> ShortByteString -> Maybe ShortByteString +stripPrefix sbs1 = \sbs2 -> do + let l1 = length sbs1 + l2 = length sbs2 + if | isPrefixOf sbs1 sbs2 -> + if null sbs1 + then Just sbs2 + else Just $! create (l2 - l1) $ \dst -> do + copyByteArray (asBA sbs2) l1 dst 0 (l2 - l1) + | otherwise -> Nothing + + +-- --------------------------------------------------------------------- +-- Unfolds and replicates + + +-- | /O(n)/ 'replicate' @n x@ is a ByteString of length @n@ with @x@ +-- the value of every element. The following holds: +-- +-- > replicate w c = unfoldr w (\u -> Just (u,u)) c +-- +-- @since 0.11.3.0 +replicate :: Int -> Word8 -> ShortByteString +replicate w c + | w <= 0 = empty + | otherwise = create w (\mba -> setByteArray mba 0 w (fromIntegral c)) + + +-- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' +-- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a +-- ShortByteString from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the ShortByteString or returns +-- 'Just' @(a,b)@, in which case, @a@ is the next byte in the string, +-- and @b@ is the seed value for further production. +-- +-- This function is not efficient/safe. It will build a list of @[Word8]@ +-- and run the generator until it returns `Nothing`, otherwise recurse infinitely, +-- then finally create a 'ShortByteString'. +-- +-- If you know the maximum length, consider using 'unfoldrN'. +-- +-- Examples: +-- +-- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0 +-- > == pack [0, 1, 2, 3, 4, 5] +-- +-- @since 0.11.3.0 +unfoldr :: (a -> Maybe (Word8, a)) -> a -> ShortByteString +unfoldr f = \x0 -> packBytesRev $ go x0 [] + where + go x words' = case f x of + Nothing -> words' + Just (w, x') -> go x' (w:words') + +-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a ShortByteString from a seed +-- value. However, the length of the result is limited by the first +-- argument to 'unfoldrN'. This function is more efficient than 'unfoldr' +-- when the maximum length of the result is known. +-- +-- The following equation relates 'unfoldrN' and 'unfoldr': +-- +-- > fst (unfoldrN n f s) == take n (unfoldr f s) +-- +-- @since 0.11.3.0 +unfoldrN :: forall a. Int -> (a -> Maybe (Word8, a)) -> a -> (ShortByteString, Maybe a) +unfoldrN i f = \x0 -> + if | i < 0 -> (empty, Just x0) + | otherwise -> createAndTrim i $ \mba -> go mba x0 0 + + where + go :: forall s. MBA s -> a -> Int -> ST s (Int, Maybe a) + go !mba !x !n = go' x n + where + go' :: a -> Int -> ST s (Int, Maybe a) + go' !x' !n' + | n' == i = return (n', Just x') + | otherwise = case f x' of + Nothing -> return (n', Nothing) + Just (w, x'') -> do + writeWord8Array mba n' w + go' x'' (n'+1) + + + +-- -------------------------------------------------------------------- +-- Predicates + +-- | Check whether one string is a substring of another. +-- +-- @since 0.11.3.0 +isInfixOf :: ShortByteString -> ShortByteString -> Bool +isInfixOf sbs = \s -> null sbs || not (null $ snd $ (GHC.Exts.inline breakSubstring) sbs s) + +-- |/O(n)/ The 'isPrefixOf' function takes two ShortByteStrings and returns 'True' +-- +-- @since 0.11.3.0 +isPrefixOf :: ShortByteString -> ShortByteString -> Bool +isPrefixOf sbs1 = \sbs2 -> do + let l1 = length sbs1 + l2 = length sbs2 + if | l1 == 0 -> True + | l2 < l1 -> False + | otherwise -> + let i = compareByteArraysOff (asBA sbs1) 0 (asBA sbs2) 0 l1 + in i == 0 + +-- | /O(n)/ The 'isSuffixOf' function takes two ShortByteStrings and returns 'True' +-- iff the first is a suffix of the second. +-- +-- The following holds: +-- +-- > isSuffixOf x y == reverse x `isPrefixOf` reverse y +-- +-- @since 0.11.3.0 +isSuffixOf :: ShortByteString -> ShortByteString -> Bool +isSuffixOf sbs1 = \sbs2 -> do + let l1 = length sbs1 + l2 = length sbs2 + if | l1 == 0 -> True + | l2 < l1 -> False + | otherwise -> + let i = compareByteArraysOff (asBA sbs1) 0 (asBA sbs2) (l2 - l1) l1 + in i == 0 + +-- | Break a string on a substring, returning a pair of the part of the +-- string prior to the match, and the rest of the string. +-- +-- The following relationships hold: +-- +-- > break (== c) l == breakSubstring (singleton c) l +-- +-- For example, to tokenise a string, dropping delimiters: +-- +-- > tokenise x y = h : if null t then [] else tokenise x (drop (length x) t) +-- > where (h,t) = breakSubstring x y +-- +-- To skip to the first occurence of a string: +-- +-- > snd (breakSubstring x y) +-- +-- To take the parts of a string before a delimiter: +-- +-- > fst (breakSubstring x y) +-- +-- Note that calling `breakSubstring x` does some preprocessing work, so +-- you should avoid unnecessarily duplicating breakSubstring calls with the same +-- pattern. +-- +-- @since 0.11.3.0 +breakSubstring :: ShortByteString -- ^ String to search for + -> ShortByteString -- ^ String to search in + -> (ShortByteString, ShortByteString) -- ^ Head and tail of string broken at substring +breakSubstring pat = + case lp of + 0 -> (empty,) + 1 -> breakByte (head pat) + _ -> if lp * 8 <= finiteBitSize (0 :: Word) + then shift + else karpRabin + where + lp = length pat + karpRabin :: ShortByteString -> (ShortByteString, ShortByteString) + karpRabin src + | length src < lp = (src,empty) + | otherwise = search (rollingHash $ take lp src) lp + where + k = 2891336453 :: Word32 + rollingHash = foldl' (\h b -> h * k + fromIntegral b) 0 + hp = rollingHash pat + m = k ^ lp + get = fromIntegral . unsafeIndex src + search !hs !i + | hp == hs && pat == take lp b = u + | length src <= i = (src, empty) -- not found + | otherwise = search hs' (i + 1) + where + u@(_, b) = splitAt (i - lp) src + hs' = hs * k + + get i - + m * get (i - lp) + {-# INLINE karpRabin #-} + + shift :: ShortByteString -> (ShortByteString, ShortByteString) + shift !src + | length src < lp = (src, empty) + | otherwise = search (intoWord $ take lp src) lp + where + intoWord :: ShortByteString -> Word + intoWord = foldl' (\w b -> (w `shiftL` 8) .|. fromIntegral b) 0 + + wp = intoWord pat + mask' = (1 `shiftL` (8 * lp)) - 1 + search !w !i + | w == wp = splitAt (i - lp) src + | length src <= i = (src, empty) + | otherwise = search w' (i + 1) + where + b = fromIntegral (unsafeIndex src i) + w' = mask' .&. ((w `shiftL` 8) .|. b) + {-# INLINE shift #-} + + +-- -------------------------------------------------------------------- +-- Searching ShortByteString + +-- | /O(n)/ 'elem' is the 'ShortByteString' membership predicate. +-- +-- @since 0.11.3.0 +elem :: Word8 -> ShortByteString -> Bool +elem c = \sbs -> case elemIndex c sbs of Nothing -> False ; _ -> True + +-- | /O(n)/ 'filter', applied to a predicate and a ByteString, +-- returns a ByteString containing those characters that satisfy the +-- predicate. +-- +-- @since 0.11.3.0 +filter :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +filter k = \sbs -> let l = length sbs + in if | l <= 0 -> sbs + | otherwise -> createAndTrim' l $ \mba -> go mba (asBA sbs) l + where + go :: forall s. MBA s -- mutable output bytestring + -> BA -- input bytestring + -> Int -- length of input bytestring + -> ST s Int + go !mba ba !l = go' 0 0 + where + go' :: Int -- bytes read + -> Int -- bytes written + -> ST s Int + go' !br !bw + | br >= l = return bw + | otherwise = do + let w = indexWord8Array ba br + if k w + then do + writeWord8Array mba bw w + go' (br+1) (bw+1) + else + go' (br+1) bw + +-- | /O(n)/ The 'find' function takes a predicate and a ByteString, +-- and returns the first element in matching the predicate, or 'Nothing' +-- if there is no such element. +-- +-- > find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing +-- +-- @since 0.11.3.0 +find :: (Word8 -> Bool) -> ShortByteString -> Maybe Word8 +find f = \sbs -> case findIndex f sbs of + Just n -> Just (sbs `index` n) + _ -> Nothing + +-- | /O(n)/ The 'partition' function takes a predicate a ByteString and returns +-- the pair of ByteStrings with elements which do and do not satisfy the +-- predicate, respectively; i.e., +-- +-- > partition p bs == (filter p sbs, filter (not . p) sbs) +-- +-- @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 + where + go :: forall s. + MBA s -- mutable output bytestring1 + -> MBA s -- mutable output bytestring2 + -> BA -- input bytestring + -> Int -- length of input bytestring + -> ST s (Int, Int) -- (length mba1, length mba2) + go !mba1 !mba2 ba !l = go' 0 0 + where + go' :: Int -- bytes read + -> Int -- bytes written to bytestring 1 + -> ST s (Int, Int) -- (length mba1, length mba2) + go' !br !bw1 + | br >= l = return (bw1, br - bw1) + | otherwise = do + let w = indexWord8Array ba br + if k w + then do + writeWord8Array mba1 bw1 w + go' (br+1) (bw1+1) + else do + writeWord8Array mba2 (br - bw1) w + go' (br+1) bw1 + + +-- -------------------------------------------------------------------- +-- Indexing ShortByteString + +-- | /O(n)/ The 'elemIndex' function returns the index of the first +-- element in the given 'ShortByteString' which is equal to the query +-- element, or 'Nothing' if there is no such element. +-- +-- @since 0.11.3.0 +elemIndex :: Word8 -> ShortByteString -> Maybe Int +elemIndex c = \sbs@(SBS ba#) -> do + let l = length sbs + accursedUnutterablePerformIO $ do + !s <- c_elem_index ba# c (fromIntegral l) + return $! if s < 0 then Nothing else Just (fromIntegral s) + + +-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning +-- the indices of all elements equal to the query element, in ascending order. +-- +-- @since 0.11.3.0 +elemIndices :: Word8 -> ShortByteString -> [Int] +elemIndices k = findIndices (==k) + +-- | count returns the number of times its argument appears in the ShortByteString +-- +-- @since 0.11.3.0 +count :: Word8 -> ShortByteString -> Int +count w = \sbs@(SBS ba#) -> accursedUnutterablePerformIO $ + fromIntegral <$> c_count ba# (fromIntegral $ length sbs) w + +-- | /O(n)/ The 'findIndex' function takes a predicate and a 'ShortByteString' and +-- returns the index of the first element in the ByteString +-- satisfying the predicate. +-- +-- @since 0.11.3.0 +findIndex :: (Word8 -> Bool) -> ShortByteString -> Maybe Int +findIndex k = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = Nothing + | k (w n) = Just n + | otherwise = go (n + 1) + in go 0 + + +-- | /O(n)/ The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending order. +-- +-- @since 0.11.3.0 +findIndices :: (Word8 -> Bool) -> ShortByteString -> [Int] +findIndices k = \sbs -> + let l = length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = [] + | k (w n) = n : go (n + 1) + | otherwise = go (n + 1) + in go 0 + + + +------------------------------------------------------------------------ +-- Exported low level operations + +copyToPtr :: ShortByteString -- ^ source data + -> Int -- ^ offset into source + -> Ptr a -- ^ destination + -> Int -- ^ number of bytes to copy + -> IO () +copyToPtr src off dst len = + stToIO $ + copyByteArrayToAddr (asBA src) off dst len + +createFromPtr :: Ptr a -- ^ source data + -> Int -- ^ number of bytes to copy + -> IO ShortByteString +createFromPtr !ptr len = + stToIO $ do + mba <- newByteArray len + copyAddrToByteArray ptr mba 0 len + BA# ba# <- unsafeFreezeByteArray mba + return (SBS ba#) + + +------------------------------------------------------------------------ +-- Primop wrappers + +data BA = BA# ByteArray# +data MBA s = MBA# (MutableByteArray# s) + +indexCharArray :: BA -> Int -> Char +indexCharArray (BA# ba#) (I# i#) = C# (indexCharArray# ba# i#) + +indexWord8Array :: BA -> Int -> Word8 +indexWord8Array (BA# ba#) (I# i#) = W8# (indexWord8Array# ba# i#) + +#if MIN_VERSION_base(4,12,0) && defined(SAFE_UNALIGNED) +indexWord8ArrayAsWord64 :: BA -> Int -> Word64 +indexWord8ArrayAsWord64 (BA# ba#) (I# i#) = W64# (indexWord8ArrayAsWord64# ba# i#) +#endif + +newByteArray :: Int -> ST s (MBA s) +newByteArray (I# len#) = + ST $ \s -> case newByteArray# len# s of + (# s, mba# #) -> (# s, MBA# mba# #) + +newPinnedByteArray :: Int -> ST s (MBA s) +newPinnedByteArray (I# len#) = + ST $ \s -> case newPinnedByteArray# len# s of + (# s, mba# #) -> (# s, MBA# mba# #) + +unsafeFreezeByteArray :: MBA s -> ST s BA +unsafeFreezeByteArray (MBA# mba#) = + ST $ \s -> case unsafeFreezeByteArray# mba# s of + (# s, ba# #) -> (# s, BA# ba# #) + +writeWord8Array :: MBA s -> Int -> Word8 -> ST s () +writeWord8Array (MBA# mba#) (I# i#) (W8# w#) = + ST $ \s -> case writeWord8Array# mba# i# w# s of + s -> (# s, () #) + +#if MIN_VERSION_base(4,12,0) && defined(SAFE_UNALIGNED) +writeWord64Array :: MBA s -> Int -> Word64 -> ST s () +writeWord64Array (MBA# mba#) (I# i#) (W64# w#) = + ST $ \s -> case writeWord64Array# mba# i# w# s of + s -> (# s, () #) +#endif + +copyAddrToByteArray :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld () +copyAddrToByteArray (Ptr src#) (MBA# dst#) (I# dst_off#) (I# len#) = + ST $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of + s -> (# s, () #) + +copyByteArrayToAddr :: BA -> Int -> Ptr a -> Int -> ST RealWorld () +copyByteArrayToAddr (BA# src#) (I# src_off#) (Ptr dst#) (I# len#) = + ST $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of + s -> (# s, () #) + +copyByteArray :: BA -> Int -> MBA s -> Int -> Int -> ST s () +copyByteArray (BA# src#) (I# src_off#) (MBA# dst#) (I# dst_off#) (I# len#) = + ST $ \s -> case copyByteArray# src# src_off# dst# dst_off# len# s of + s -> (# s, () #) + +setByteArray :: MBA s -> Int -> Int -> Int -> ST s () +setByteArray (MBA# dst#) (I# off#) (I# len#) (I# c#) = + ST $ \s -> case setByteArray# dst# off# len# c# s of + s -> (# s, () #) + +copyMutableByteArray :: MBA s -> Int -> MBA s -> Int -> Int -> ST s () +copyMutableByteArray (MBA# src#) (I# src_off#) (MBA# dst#) (I# dst_off#) (I# len#) = + ST $ \s -> case copyMutableByteArray# src# src_off# dst# dst_off# len# s of + s -> (# s, () #) + + +------------------------------------------------------------------------ +-- FFI imports +-- +compareByteArrays :: BA -> BA -> Int -> Int +compareByteArrays ba1 ba2 = compareByteArraysOff ba1 0 ba2 0 + +compareByteArraysOff :: BA -- ^ array 1 + -> Int -- ^ offset for array 1 + -> BA -- ^ array 2 + -> Int -- ^ offset for array 2 + -> Int -- ^ length to compare + -> Int -- ^ like memcmp +#if MIN_VERSION_base(4,11,0) +compareByteArraysOff (BA# ba1#) (I# ba1off#) (BA# ba2#) (I# ba2off#) (I# len#) = + I# (compareByteArrays# ba1# ba1off# ba2# ba2off# len#) +#else +compareByteArraysOff (BA# ba1#) ba1off (BA# ba2#) ba2off len = + assert (ba1off + len <= (I# (sizeofByteArray# ba1#))) + $ assert (ba2off + len <= (I# (sizeofByteArray# ba2#))) + $ fromIntegral $ accursedUnutterablePerformIO $ + c_memcmp_ByteArray ba1# + ba1off + ba2# + ba2off + (fromIntegral len) + + +foreign import ccall unsafe "static sbs_memcmp_off" + c_memcmp_ByteArray :: ByteArray# -> Int -> ByteArray# -> Int -> CSize -> IO CInt +#endif + +foreign import ccall unsafe "static sbs_elem_index" + c_elem_index :: ByteArray# -> Word8 -> CSize -> IO CPtrdiff + +foreign import ccall unsafe "static fpstring.h fps_count" c_count + :: ByteArray# -> CSize -> Word8 -> IO CSize + + +------------------------------------------------------------------------ +-- Primop replacements + +copyAddrToByteArray# :: Addr# + -> MutableByteArray# RealWorld -> Int# + -> Int# + -> State# RealWorld -> State# RealWorld + +copyByteArrayToAddr# :: ByteArray# -> Int# + -> Addr# + -> Int# + -> State# RealWorld -> State# RealWorld + +copyByteArray# :: ByteArray# -> Int# + -> MutableByteArray# s -> Int# + -> Int# + -> State# s -> State# s + +copyAddrToByteArray# = GHC.Exts.copyAddrToByteArray# +copyByteArrayToAddr# = GHC.Exts.copyByteArrayToAddr# +copyByteArray# = GHC.Exts.copyByteArray# + +-- | /O(n)./ Construct a new @ShortByteString@ from a @CString@. The +-- resulting @ShortByteString@ is an immutable copy of the original +-- @CString@, and is managed on the Haskell heap. The original +-- @CString@ must be null terminated. +-- +-- @since 0.10.10.0 +packCString :: CString -> IO ShortByteString +packCString cstr = do + len <- BS.c_strlen cstr + packCStringLen (cstr, fromIntegral len) + +-- | /O(n)./ Construct a new @ShortByteString@ from a @CStringLen@. The +-- resulting @ShortByteString@ is an immutable copy of the original @CStringLen@. +-- The @ShortByteString@ is a normal Haskell value and will be managed on the +-- Haskell heap. +-- +-- @since 0.10.10.0 +packCStringLen :: CStringLen -> IO ShortByteString +packCStringLen (cstr, len) | len >= 0 = createFromPtr cstr len +packCStringLen (_, len) = + moduleErrorIO "packCStringLen" ("negative length: " ++ show len) + +-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a +-- null-terminated @CString@. The @CString@ is a copy and will be freed +-- automatically; it must not be stored or used after the +-- subcomputation finishes. +-- +-- @since 0.10.10.0 +useAsCString :: ShortByteString -> (CString -> IO a) -> IO a +useAsCString sbs action = + allocaBytes (l+1) $ \buf -> do + copyToPtr sbs 0 buf (fromIntegral l) + pokeByteOff buf l (0::Word8) + action buf + where l = length sbs + +-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a @CStringLen@. +-- As for @useAsCString@ this function makes a copy of the original @ShortByteString@. +-- It must not be stored or used after the subcomputation finishes. +-- +-- @since 0.10.10.0 +useAsCStringLen :: ShortByteString -> (CStringLen -> IO a) -> IO a +useAsCStringLen sbs action = + allocaBytes l $ \buf -> do + copyToPtr sbs 0 buf (fromIntegral l) + action (buf, l) + where l = length sbs + +-- | /O(n)/ Check whether a 'ShortByteString' represents valid UTF-8. +-- +-- @since 0.11.3.0 +isValidUtf8 :: ShortByteString -> Bool +isValidUtf8 sbs@(SBS ba#) = accursedUnutterablePerformIO $ do + let n = length sbs + -- Use a safe FFI call for large inputs to avoid GC synchronization pauses + -- in multithreaded contexts. + -- This specific limit was chosen based on results of a simple benchmark, see: + -- https://github.com/haskell/bytestring/issues/451#issuecomment-991879338 + -- When changing this function, also consider changing the related function: + -- Data.ByteString.isValidUtf8 + i <- if n < 1000000 || not (isPinned ba#) + then cIsValidUtf8 ba# (fromIntegral n) + else cIsValidUtf8Safe ba# (fromIntegral n) + IO (\s -> (# touch# ba# s, () #)) + return $ i /= 0 + +-- We import bytestring_is_valid_utf8 both unsafe and safe. For small inputs +-- we can use the unsafe version to get a bit more performance, but for large +-- inputs the safe version should be used to avoid GC synchronization pauses +-- in multithreaded contexts. + +foreign import ccall unsafe "bytestring_is_valid_utf8" cIsValidUtf8 + :: ByteArray# -> CSize -> IO CInt + +foreign import ccall safe "bytestring_is_valid_utf8" cIsValidUtf8Safe + :: ByteArray# -> CSize -> IO CInt + +-- --------------------------------------------------------------------- +-- Internal utilities + +moduleErrorIO :: HasCallStack => String -> String -> IO a +moduleErrorIO fun msg = throwIO . userError $ moduleErrorMsg fun msg +{-# NOINLINE moduleErrorIO #-} + +moduleErrorMsg :: String -> String -> String +moduleErrorMsg fun msg = "Data.ByteString.Short." ++ fun ++ ':':' ':msg + + +-- Find from the end of the string using predicate. +-- +-- Return '0' if the predicate returns false for the entire ShortByteString. +findFromEndUntil :: (Word8 -> Bool) -> ShortByteString -> Int +findFromEndUntil k sbs = go (length sbs - 1) + where + ba = asBA sbs + go !n | n < 0 = 0 + | k (indexWord8Array ba n) = n + 1 + | otherwise = go (n - 1) + +findIndexOrLength :: (Word8 -> Bool) -> ShortByteString -> Int +findIndexOrLength k sbs = go 0 + where + l = length sbs + ba = asBA sbs + go !n | n >= l = l + | k (indexWord8Array ba n) = n + | otherwise = go (n + 1) + + +packBytesRev :: [Word8] -> ShortByteString +packBytesRev cs = packLenBytesRev (List.length cs) cs + +packLenBytesRev :: Int -> [Word8] -> ShortByteString +packLenBytesRev len ws0 = + create len (\mba -> go mba len ws0) + where + go :: MBA s -> Int -> [Word8] -> ST s () + go !_ !_ [] = return () + go !mba !i (w:ws) = do + writeWord8Array mba (i - 1) w + go mba (i - 1) ws + + +breakByte :: Word8 -> ShortByteString -> (ShortByteString, ShortByteString) +breakByte c sbs = case elemIndex c sbs of + Nothing -> (sbs, empty) + Just n -> (take n sbs, drop n sbs) + +-- Common up near identical calls to `error' to reduce the number +-- constant strings created when compiled: +errorEmptySBS :: HasCallStack => String -> a +errorEmptySBS fun = moduleError fun "empty ShortByteString" +{-# NOINLINE errorEmptySBS #-} + +moduleError :: HasCallStack => String -> String -> a +moduleError fun msg = error (moduleErrorMsg fun msg) +{-# NOINLINE moduleError #-} + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # ByteString: Fast, Packed Strings of Bytes -[![Build Status](https://github.com/haskell/bytestring/workflows/ci/badge.svg)](https://github.com/haskell/bytestring/actions?query=workflow%3Aci) [![Hackage](http://img.shields.io/hackage/v/bytestring.svg)](https://hackage.haskell.org/package/bytestring) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/bytestring/badge)](https://matrix.hackage.haskell.org/package/bytestring) [![Stackage LTS](http://stackage.org/package/bytestring/badge/lts)](http://stackage.org/lts/package/bytestring) [![Stackage Nightly](http://stackage.org/package/bytestring/badge/nightly)](http://stackage.org/nightly/package/bytestring) +[![Build Status](https://github.com/haskell/bytestring/workflows/ci/badge.svg)](https://github.com/haskell/bytestring/actions?query=workflow%3Aci) [![Hackage](http://img.shields.io/hackage/v/bytestring.svg)](https://hackage.haskell.org/package/bytestring) [![Stackage LTS](http://stackage.org/package/bytestring/badge/lts)](http://stackage.org/lts/package/bytestring) [![Stackage Nightly](http://stackage.org/package/bytestring/badge/nightly)](http://stackage.org/nightly/package/bytestring) This library provides the `Data.ByteString` module -- strict and lazy byte arrays manipulable as strings -- providing very time/space-efficient @@ -16,7 +16,7 @@ Requirements: * Cabal 1.10 or greater - * GHC 7.0 or greater + * GHC 8.0 or greater ### Authors diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -23,6 +23,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 import Data.ByteString.Builder import Data.ByteString.Builder.Extra (byteStringCopy, @@ -42,6 +43,7 @@ import BenchCount import BenchCSV import BenchIndices +import BenchShort ------------------------------------------------------------------------------ -- Benchmark support @@ -375,6 +377,11 @@ [ bench "intersperse" $ whnf (S.intersperse 32) byteStringData , bench "intersperse (unaligned)" $ whnf (S.intersperse 32) (S.drop 1 byteStringData) ] + , bgroup "intercalate" + [ bench "intercalate (large)" $ whnf (S.intercalate $ S8.pack " and also ") (replicate 300 (S8.pack "expression")) + , bench "intercalate (small)" $ whnf (S.intercalate $ S8.pack "&") (replicate 30 (S8.pack "foo")) + , bench "intercalate (tiny)" $ whnf (S.intercalate $ S8.pack "&") (S8.pack <$> ["foo", "bar", "baz"]) + ] , bgroup "partition" [ bgroup "strict" @@ -463,8 +470,13 @@ [ bench "map (+1) large" $ nf (S.map (+ 1)) largeTraversalInput , bench "map (+1) small" $ nf (S.map (+ 1)) smallTraversalInput ] + , bgroup "unlines" + [ bench "lazy" $ nf L8.unlines (map (L8.pack . show) intData) + , bench "strict" $ nf S8.unlines (map (S8.pack . show) intData) + ] , benchBoundsCheckFusion , benchCount , benchCSV , benchIndices + , benchShort ] diff --git a/bench/BenchCSV.hs b/bench/BenchCSV.hs --- a/bench/BenchCSV.hs +++ b/bench/BenchCSV.hs @@ -14,9 +14,9 @@ module BenchCSV (benchCSV) where --- ************************************************************************** +-- ************************************************************************** -- CamHac 2011: An introduction to Data.ByteString.Builder --- ************************************************************************** +-- ************************************************************************** {- The Encoding Problem diff --git a/bench/BenchShort.hs b/bench/BenchShort.hs new file mode 100644 --- /dev/null +++ b/bench/BenchShort.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} + +module BenchShort (benchShort) where + +import Data.Foldable (foldMap) +import Data.Maybe (listToMaybe) +import Data.Monoid +import Data.String +import Test.Tasty.Bench +import Prelude hiding (words) + +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as S + +import Data.ByteString.Builder +import Data.ByteString.Builder.Extra (byteStringCopy, + byteStringInsert, + intHost) +import Data.ByteString.Builder.Internal (ensureFree) +import Data.ByteString.Builder.Prim (BoundedPrim, FixedPrim, + (>$<)) +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Builder.Prim.Internal as PI + +import Foreign + +import System.Random + + + +------------------------------------------------------------------------------ +-- Benchmark +------------------------------------------------------------------------------ + +-- input data (NOINLINE to ensure memoization) +---------------------------------------------- + +-- | Few-enough repetitions to avoid making GC too expensive. +nRepl :: Int +nRepl = 10000 + +{-# NOINLINE intData #-} +intData :: [Int] +intData = [1..nRepl] + +{-# NOINLINE byteStringData #-} +byteStringData :: S.ShortByteString +byteStringData = S.pack $ map fromIntegral intData + +{-# NOINLINE loremIpsum #-} +loremIpsum :: S.ShortByteString +loremIpsum = mconcat + [ " Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor" + , "incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis" + , "nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat." + , "Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu" + , "fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in" + , "culpa qui officia deserunt mollit anim id est laborum." + ] + +-- benchmark wrappers +--------------------- + +{-# INLINE benchB' #-} +benchB' :: String -> a -> (a -> ShortByteString) -> Benchmark +benchB' name x b = bench name $ whnf (S.length . b) x + + +-- We use this construction of just looping through @n,n-1,..,1@ to ensure that +-- we measure the speed of the encoding and not the speed of generating the +-- values to be encoded. +{-# INLINE benchIntEncodingB #-} +benchIntEncodingB :: Int -- ^ Maximal 'Int' to write + -> BoundedPrim Int -- ^ 'BoundedPrim' to execute + -> IO () -- ^ 'IO' action to benchmark +benchIntEncodingB n0 w + | n0 <= 0 = return () + | otherwise = do + fpbuf <- mallocForeignPtrBytes (n0 * PI.sizeBound w) + withForeignPtr fpbuf (loop n0) >> return () + where + loop !n !op + | n <= 0 = return op + | otherwise = PI.runB w n op >>= loop (n - 1) + + +-- Helpers +------------- + +hashInt :: Int -> Int +hashInt x = iterate step x !! 10 + where + step a = e + where b = (a `xor` 61) `xor` (a `shiftR` 16) + c = b + (b `shiftL` 3) + d = c `xor` (c `shiftR` 4) + e = d * 0x27d4eb2d + f = e `xor` (e `shiftR` 15) + +w :: Int -> Word8 +w = fromIntegral + +hashWord8 :: Word8 -> Word8 +hashWord8 = fromIntegral . hashInt . fromIntegral + +foldInputs :: [S.ShortByteString] +foldInputs = map (\k -> S.pack $ if k <= 6 then take (2 ^ k) [32..95] else concat (replicate (2 ^ (k - 6)) [32..95])) [0..16] + +largeTraversalInput :: S.ShortByteString +largeTraversalInput = S.concat (replicate 10 byteStringData) + +smallTraversalInput :: S.ShortByteString +smallTraversalInput = "The quick brown fox" + +zeroes :: S.ShortByteString +zeroes = S.replicate 10000 0 + +partitionStrict p = nf (S.partition p) . randomStrict $ mkStdGen 98423098 + where randomStrict = fst . S.unfoldrN 10000 (Just . random) + +-- ASCII \n to ensure no typos +nl :: Word8 +nl = 0xa +{-# INLINE nl #-} + +-- non-inlined equality test +nilEq :: Word8 -> Word8 -> Bool +{-# NOINLINE nilEq #-} +nilEq = (==) + +-- lines of 200 letters from a to e, followed by repeated letter f +absurdlong :: S.ShortByteString +absurdlong = S.replicate 200 0x61 <> S.singleton nl + <> S.replicate 200 0x62 <> S.singleton nl + <> S.replicate 200 0x63 <> S.singleton nl + <> S.replicate 200 0x64 <> S.singleton nl + <> S.replicate 200 0x65 <> S.singleton nl + <> S.replicate 999999 0x66 + +bench_find_index_second :: ShortByteString -> Maybe Int +bench_find_index_second bs = + let isNl = (== nl) + in case S.findIndex isNl bs of + Just !i -> S.findIndex isNl (S.drop (i+1) bs) + Nothing -> Nothing +{-# INLINE bench_find_index_second #-} + +bench_elem_index_second :: ShortByteString -> Maybe Int +bench_elem_index_second bs = + case S.elemIndex nl bs of + Just !i -> S.elemIndex nl (S.drop (i+1) bs) + Nothing -> Nothing +{-# INLINE bench_elem_index_second #-} + + + +-- benchmarks +------------- + +benchShort :: Benchmark +benchShort = bgroup "ShortByteString" + [ bgroup "Small payload" + [ benchB' "mempty" () (const mempty) + , benchB' "UTF-8 String (naive)" "hello world\0" fromString + , benchB' "String (naive)" "hello world!" fromString + ] + , bgroup "intercalate" + [ bench "intercalate (large)" $ whnf (S.intercalate $ " and also ") (replicate 300 "expression") + , bench "intercalate (small)" $ whnf (S.intercalate "&") (replicate 30 "foo") + , bench "intercalate (tiny)" $ whnf (S.intercalate "&") (["foo", "bar", "baz"]) + ] + , bgroup "partition" + [ + bgroup "strict" + [ + bench "mostlyTrueFast" $ partitionStrict (< (w 225)) + , bench "mostlyFalseFast" $ partitionStrict (< (w 10)) + , bench "balancedFast" $ partitionStrict (< (w 128)) + + , bench "mostlyTrueSlow" $ partitionStrict (\x -> hashWord8 x < w 225) + , bench "mostlyFalseSlow" $ partitionStrict (\x -> hashWord8 x < w 10) + , bench "balancedSlow" $ partitionStrict (\x -> hashWord8 x < w 128) + ] + ] + , bgroup "folds" + [ bgroup "strict" + [ bgroup "foldl'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldl' (\acc x -> acc + fromIntegral x) (0 :: Int)) s) foldInputs + , bgroup "foldr'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldr' (\x acc -> fromIntegral x + acc) (0 :: Int)) s) foldInputs + , bgroup "foldr1'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldr1' (\x acc -> fromIntegral x + acc)) s) foldInputs + , bgroup "unfoldrN" $ map (\s -> bench (show $ S.length s) $ + nf (S.unfoldrN (S.length s) (\a -> Just (a, a + 1))) 0) foldInputs + , bgroup "filter" $ map (\s -> bench (show $ S.length s) $ + nf (S.filter odd) s) foldInputs + ] + ] + , bgroup "findIndexOrLength" + [ bench "takeWhile" $ nf (S.takeWhile even) zeroes + , bench "dropWhile" $ nf (S.dropWhile even) zeroes + , bench "break" $ nf (S.break odd) zeroes + ] + , bgroup "findIndex_" + [ bench "findIndices" $ nf (sum . S.findIndices (\x -> x == 129 || x == 72)) byteStringData + , bench "find" $ nf (S.find (>= 198)) byteStringData + ] + , bgroup "traversals" + [ bench "map (+1) large" $ nf (S.map (+ 1)) largeTraversalInput + , bench "map (+1) small" $ nf (S.map (+ 1)) smallTraversalInput + ] + , bgroup "ShortByteString strict first index" $ + [ bench "FindIndices" $ nf (listToMaybe . S.findIndices (== nl)) absurdlong + , bench "ElemIndices" $ nf (listToMaybe . S.elemIndices nl) absurdlong + , bench "FindIndex" $ nf (S.findIndex (== nl)) absurdlong + , bench "ElemIndex" $ nf (S.elemIndex nl) absurdlong + ] + , bgroup "ShortByteString strict second index" $ + [ bench "FindIndices" $ nf (listToMaybe . tail . S.findIndices (== nl)) absurdlong + , bench "ElemIndices" $ nf (listToMaybe . tail . S.elemIndices nl) absurdlong + , bench "FindIndex" $ nf bench_find_index_second absurdlong + , bench "ElemIndex" $ nf bench_elem_index_second absurdlong + ] + , bgroup "ShortByteString index equality inlining" $ + [ bench "FindIndices/inlined" $ nf (S.findIndices (== nl)) absurdlong + , bench "FindIndices/non-inlined" $ nf (S.findIndices (nilEq nl)) absurdlong + , bench "FindIndex/inlined" $ nf (S.findIndex (== nl)) absurdlong + , bench "FindIndex/non-inlined" $ nf (S.findIndex (nilEq nl)) absurdlong + ] + ] + diff --git a/bytestring.cabal b/bytestring.cabal --- a/bytestring.cabal +++ b/bytestring.cabal @@ -1,5 +1,5 @@ Name: bytestring -Version: 0.11.2.0 +Version: 0.11.3.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) @@ -121,13 +121,15 @@ c-sources: cbits/fpstring.c cbits/itoa.c + cbits/shortbytestring.c if (arch(aarch64)) c-sources: cbits/aarch64/is-valid-utf8.c else c-sources: cbits/is-valid-utf8.c - cc-options: -std=c11 + -- DNDEBUG disables asserts in cbits/ + cc-options: -std=c11 -DNDEBUG=1 -- Required, due to the following issues: -- * https://gitlab.haskell.org/ghc/ghc/-/issues/20525#note_385580 @@ -154,6 +156,7 @@ Properties.ByteStringChar8 Properties.ByteStringLazy Properties.ByteStringLazyChar8 + Properties.ShortByteString QuickCheckUtils hs-source-dirs: tests, tests/builder @@ -176,6 +179,7 @@ BenchCount BenchCSV BenchIndices + BenchShort type: exitcode-stdio-1.0 hs-source-dirs: bench default-language: Haskell2010 diff --git a/cbits/fpstring.c b/cbits/fpstring.c --- a/cbits/fpstring.c +++ b/cbits/fpstring.c @@ -38,8 +38,9 @@ #include #include -#ifndef __STDC_NO_ATOMICS__ +#if defined(__x86_64__) && (__GNUC__ >= 6 || defined(__clang_major__)) && !defined(__STDC_NO_ATOMICS__) #include +#define USE_SIMD_COUNT #endif /* copy a string in reverse */ @@ -114,9 +115,6 @@ return c; } -#if defined(__x86_64__) && (__GNUC__ >= 6 || defined(__clang_major__)) && !defined(__STDC_NO_ATOMICS__) -#define USE_SIMD_COUNT -#endif #ifdef USE_SIMD_COUNT __attribute__((target("sse4.2"))) diff --git a/cbits/is-valid-utf8.c b/cbits/is-valid-utf8.c --- a/cbits/is-valid-utf8.c +++ b/cbits/is-valid-utf8.c @@ -32,17 +32,20 @@ #include #include #include +#include #ifdef __x86_64__ #include #include -#include #include -#endif - -#ifndef __STDC_NO_ATOMICS__ +#if (__GNUC__ >= 6 || defined(__clang_major__)) && !defined(__STDC_NO_ATOMICS__) +#include #include +#else +// This is needed to support CentOS 7, which has a very old GCC. +#define CRUFTY_GCC #endif +#endif #include @@ -55,6 +58,12 @@ // 0x80 in every 'lane'. static uint64_t const high_bits_mask = 0x8080808080808080ULL; +static inline uint64_t read_uint64(const uint64_t *p) { + uint64_t r; + memcpy(&r, p, 8); + return r; +} + static inline int is_valid_utf8_fallback(uint8_t const *const src, size_t const len) { uint8_t const *ptr = (uint8_t const *)src; // This is 'one past the end' to make loop termination and bounds checks @@ -74,10 +83,10 @@ // Non-ASCII bytes have a set MSB. Thus, if we AND with 0x80 in every // 'lane', we will get 0 if everything is ASCII, and something else // otherwise. - uint64_t results[4] = {to_little_endian(*big_ptr) & high_bits_mask, - to_little_endian(*(big_ptr + 1)) & high_bits_mask, - to_little_endian(*(big_ptr + 2)) & high_bits_mask, - to_little_endian(*(big_ptr + 3)) & high_bits_mask}; + uint64_t results[4] = {to_little_endian(read_uint64(big_ptr)) & high_bits_mask, + to_little_endian(read_uint64((big_ptr + 1))) & high_bits_mask, + to_little_endian(read_uint64((big_ptr + 2))) & high_bits_mask, + to_little_endian(read_uint64((big_ptr + 3))) & high_bits_mask}; if (results[0] == 0) { ptr += 8; if (results[1] == 0) { @@ -154,7 +163,7 @@ return 1; } -#ifdef __x86_64__ +#if defined(__x86_64__) && !defined(CRUFTY_GCC) // SSE2 @@ -651,7 +660,7 @@ #endif -#ifdef __x86_64__ +#if defined(__x86_64__) && !defined(CRUFTY_GCC) static inline bool has_sse2() { uint32_t eax = 0, ebx = 0, ecx = 0, edx = 0; __get_cpuid_count(1, 0, &eax, &ebx, &ecx, &edx); @@ -680,7 +689,7 @@ if (len == 0) { return 1; } -#ifdef __x86_64__ +#if defined(__x86_64__) && !defined(CRUFTY_GCC) static _Atomic is_valid_utf8_t s_impl = (is_valid_utf8_t)NULL; is_valid_utf8_t impl = atomic_load_explicit(&s_impl, memory_order_relaxed); if (!impl) { diff --git a/cbits/shortbytestring.c b/cbits/shortbytestring.c new file mode 100644 --- /dev/null +++ b/cbits/shortbytestring.c @@ -0,0 +1,35 @@ +#include +#include +#include + + +int +sbs_memcmp_off(const void *s1, + size_t off1, + const void *s2, + size_t off2, + size_t n) +{ + const void *s1o = s1 + off1; + const void *s2o = s2 + off2; + + int r = memcmp(s1o, s2o, n); + + return r; +} + +ptrdiff_t +sbs_elem_index(const void *s, + int c, + size_t n) +{ + const void *so = memchr(s, c, n); + + if (so) { + ptrdiff_t diff = so - s; + assert(diff >= 0); + return diff; + } else { + return -1; + } +} diff --git a/tests/IsValidUtf8.hs b/tests/IsValidUtf8.hs --- a/tests/IsValidUtf8.hs +++ b/tests/IsValidUtf8.hs @@ -4,6 +4,7 @@ import Data.Bits (shiftR, (.&.), shiftL) import Data.ByteString (ByteString) +import qualified Data.ByteString.Short as SBS import qualified Data.ByteString as B import Data.Char (chr, ord) import Data.Word (Word8) @@ -17,17 +18,25 @@ testSuite :: TestTree testSuite = testGroup "UTF-8 validation" $ [ - adjustOption (max testCount) . testProperty "Valid UTF-8" $ goValid, - adjustOption (max testCount) . testProperty "Invalid UTF-8" $ goInvalid, + adjustOption (max testCount) . testProperty "Valid UTF-8 ByteString" $ goValidBS, + adjustOption (max testCount) . testProperty "Invalid UTF-8 ByteString" $ goInvalidBS, + adjustOption (max testCount) . testProperty "Valid UTF-8 ShortByteString" $ goValidSBS, + adjustOption (max testCount) . testProperty "Invalid UTF-8 ShortByteString" $ goInvalidSBS, testGroup "Regressions" checkRegressions ] where - goValid :: Property - goValid = forAll arbitrary $ + goValidBS :: Property + goValidBS = forAll arbitrary $ \(ValidUtf8 ss) -> (B.isValidUtf8 . foldMap sequenceToBS $ ss) === True - goInvalid :: Property - goInvalid = forAll arbitrary $ + goInvalidBS :: Property + goInvalidBS = forAll arbitrary $ \inv -> (B.isValidUtf8 . toByteString $ inv) === False + goValidSBS :: Property + goValidSBS = forAll arbitrary $ + \(ValidUtf8 ss) -> (SBS.isValidUtf8 . SBS.toShort . foldMap sequenceToBS $ ss) === True + goInvalidSBS :: Property + goInvalidSBS = forAll arbitrary $ + \inv -> (SBS.isValidUtf8 . SBS.toShort . toByteString $ inv) === False testCount :: QuickCheckTests testCount = 1000 diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -52,6 +52,7 @@ import Test.Tasty import Test.Tasty.QuickCheck +import qualified Properties.ShortByteString as PropSBS import qualified Properties.ByteString as PropBS import qualified Properties.ByteStringChar8 as PropBS8 import qualified Properties.ByteStringLazy as PropBL @@ -397,14 +398,15 @@ testSuite :: TestTree testSuite = testGroup "Properties" - [ testGroup "StrictWord8" PropBS.tests - , testGroup "StrictChar8" PropBS8.tests - , testGroup "LazyWord8" PropBL.tests - , testGroup "LazyChar8" PropBL8.tests - , testGroup "Misc" misc_tests - , testGroup "IO" io_tests - , testGroup "Short" short_tests - , testGroup "Strictness" strictness_checks + [ testGroup "ShortByteString" PropSBS.tests + , testGroup "StrictWord8" PropBS.tests + , testGroup "StrictChar8" PropBS8.tests + , testGroup "LazyWord8" PropBL.tests + , testGroup "LazyChar8" PropBL8.tests + , testGroup "Misc" misc_tests + , testGroup "IO" io_tests + , testGroup "Short" short_tests + , testGroup "Strictness" strictness_checks ] io_tests = @@ -491,6 +493,7 @@ D.take (D.length xs + 1) (D.scanl (+.) '\NUL' (explosiveTail (xs <> D.singleton '\SOH'))) === (D.pack . fmap (D.foldr (+.) '\NUL') . D.inits) xs , testProperty "scanl1 is lazy" $ \ xs -> D.length xs > 0 ==> let char1 +. char2 = toEnum (fromEnum char1 + fromEnum char2) in D.take (D.length xs) (D.scanl1 (+.) (explosiveTail (xs <> D.singleton '\SOH'))) === (D.pack . fmap (D.foldr1 (+.)) . tail . D.inits) xs + , testProperty "unlines is lazy" $ \ xs -> D.take (D.length xs + 1) (D.unlines (xs : error "Tail of this list is undefined!")) === xs `D.snoc` '\n' ] ] diff --git a/tests/Properties/ByteString.hs b/tests/Properties/ByteString.hs --- a/tests/Properties/ByteString.hs +++ b/tests/Properties/ByteString.hs @@ -20,12 +20,19 @@ -- Properties.ByteString{Char8,Lazy,LazyChar8}, which include this file. #ifndef BYTESTRING_CHAR8 -#ifndef BYTESTRING_LAZY +#if defined(BYTESTRING_SHORT) +module Properties.ShortByteString (tests) where +import qualified Data.ByteString.Short as B +import qualified Data.ByteString.Short.Internal as B +#define BYTESTRING_TYPE B.ShortByteString +#elif !(defined BYTESTRING_LAZY) module Properties.ByteString (tests) where +#define BYTESTRING_TYPE B.ByteString import qualified Data.ByteString as B import GHC.IO.Encoding #else module Properties.ByteStringLazy (tests) where +#define BYTESTRING_TYPE B.ByteString import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Internal as B (invariant) #endif @@ -37,10 +44,12 @@ #ifndef BYTESTRING_LAZY module Properties.ByteStringChar8 (tests) where import qualified Data.ByteString.Char8 as B +#define BYTESTRING_TYPE B.ByteString #else module Properties.ByteStringLazyChar8 (tests) where import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.ByteString.Lazy.Internal as B (invariant) +#define BYTESTRING_TYPE B.ByteString #endif import Text.Read @@ -73,13 +82,14 @@ , testProperty "unpack . pack" $ \(map toElem -> xs) -> xs === B.unpack (B.pack xs) , testProperty "read . show" $ - \x -> (x :: B.ByteString) === read (show x) + \x -> (x :: BYTESTRING_TYPE) === read (show x) +#ifndef BYTESTRING_SHORT , testProperty "fromStrict . toStrict" $ \x -> B.fromStrict (B.toStrict x) === x , testProperty "toStrict . fromStrict" $ \x -> B.toStrict (B.fromStrict x) === x -#ifndef BYTESTRING_LAZY -#ifndef BYTESTRING_CHAR8 +#endif +#if !defined(BYTESTRING_LAZY) && !defined(BYTESTRING_CHAR8) && !defined(BYTESTRING_SHORT) , testProperty "toFilePath >>= fromFilePath" $ \x -> ioProperty $ do r <- B.toFilePath x >>= B.fromFilePath @@ -95,23 +105,24 @@ "ASCII" -> property (prop . getASCIIString) _ -> property prop #endif -#endif , testProperty "==" $ \x y -> (x == y) === (B.unpack x == B.unpack y) , testProperty "== refl" $ - \x -> (x :: B.ByteString) == x + \x -> (x :: BYTESTRING_TYPE) == x , testProperty "== symm" $ - \x y -> ((x :: B.ByteString) == y) === (y == x) + \x y -> ((x :: BYTESTRING_TYPE) == y) === (y == x) , testProperty "== pack unpack" $ \x -> x == B.pack (B.unpack x) +#ifndef BYTESTRING_SHORT , testProperty "== copy" $ \x -> x == B.copy x +#endif , testProperty "compare" $ \x y -> compare x y === compare (B.unpack x) (B.unpack y) , testProperty "compare EQ" $ - \x -> compare (x :: B.ByteString) x == EQ + \x -> compare (x :: BYTESTRING_TYPE) x == EQ , testProperty "compare GT" $ \x (toElem -> c) -> compare (B.snoc x c) x == GT , testProperty "compare LT" $ @@ -157,6 +168,7 @@ \x -> B.null x === null (B.unpack x) , testProperty "reverse" $ \x -> B.unpack (B.reverse x) === reverse (B.unpack x) +#ifndef BYTESTRING_SHORT , testProperty "transpose" $ \xs -> map B.unpack (B.transpose xs) === List.transpose (map B.unpack xs) , testProperty "group" $ @@ -171,6 +183,7 @@ \x -> map B.unpack (B.inits x) === List.inits (B.unpack x) , testProperty "tails" $ \x -> map B.unpack (B.tails x) === List.tails (B.unpack x) +#endif , testProperty "all" $ \f x -> B.all f x === all f (B.unpack x) , testProperty "all ==" $ @@ -185,8 +198,10 @@ \x y -> B.unpack (mappend x y) === B.unpack x `mappend` B.unpack y , testProperty "<>" $ \x y -> B.unpack (x <> y) === B.unpack x <> B.unpack y +#ifndef BYTESTRING_SHORT , testProperty "stimes" $ - \(Sqrt (NonNegative n)) (Sqrt x) -> stimes (n :: Int) (x :: B.ByteString) === mtimesDefault n x + \(Sqrt (NonNegative n)) (Sqrt x) -> stimes (n :: Int) (x :: BYTESTRING_TYPE) === mtimesDefault n x +#endif , testProperty "break" $ \f x -> (B.unpack *** B.unpack) (B.break f x) === break f (B.unpack x) @@ -214,10 +229,12 @@ \x -> (B.unpack *** B.unpack) (B.break isSpace x) === break isSpace (B.unpack x) #endif +#ifndef BYTESTRING_SHORT , testProperty "concatMap" $ \f x -> B.unpack (B.concatMap f x) === concatMap (B.unpack . f) (B.unpack x) , testProperty "concatMap singleton" $ \x -> B.unpack (B.concatMap B.singleton x) === concatMap (: []) (B.unpack x) +#endif , testProperty "singleton" $ \(toElem -> c) -> B.unpack (B.singleton c) === [c] @@ -334,8 +351,10 @@ \f x -> B.find f x === find f (B.unpack x) , testProperty "findIndex" $ \f x -> B.findIndex f x === fmap fromIntegral (List.findIndex f (B.unpack x)) +#ifndef BYTESTRING_SHORT , testProperty "findIndexEnd" $ \f x -> B.findIndexEnd f x === fmap fromIntegral (findIndexEnd f (B.unpack x)) +#endif , testProperty "findIndices" $ \f x -> B.findIndices f x === fmap fromIntegral (List.findIndices f (B.unpack x)) , testProperty "findIndices ==" $ @@ -343,12 +362,16 @@ , testProperty "elem" $ \(toElem -> c) x -> B.elem c x === elem c (B.unpack x) +#ifndef BYTESTRING_SHORT , testProperty "notElem" $ \(toElem -> c) x -> B.notElem c x === notElem c (B.unpack x) +#endif , testProperty "elemIndex" $ \(toElem -> c) x -> B.elemIndex c x === fmap fromIntegral (List.elemIndex c (B.unpack x)) +#ifndef BYTESTRING_SHORT , testProperty "elemIndexEnd" $ \(toElem -> c) x -> B.elemIndexEnd c x === fmap fromIntegral (elemIndexEnd c (B.unpack x)) +#endif , testProperty "elemIndices" $ \(toElem -> c) x -> B.elemIndices c x === fmap fromIntegral (List.elemIndices c (B.unpack x)) @@ -415,10 +438,12 @@ \x -> not (B.null x) ==> B.unpack (B.init x) === init (B.unpack x) , testProperty "init length" $ \x -> not (B.null x) ==> B.length x === 1 + B.length (B.init x) +#ifndef BYTESTRING_SHORT , testProperty "maximum" $ \x -> not (B.null x) ==> B.maximum x === maximum (B.unpack x) , testProperty "minimum" $ \x -> not (B.null x) ==> B.minimum x === minimum (B.unpack x) +#endif , testProperty "foldl" $ \f (toElem -> c) x -> B.foldl ((toElem .) . f) c x === foldl ((toElem .) . f) c (B.unpack x) @@ -462,6 +487,7 @@ , testProperty "foldr1 max" $ \x -> not (B.null x) ==> B.foldr1 max x === B.foldr max minBound x +#ifndef BYTESTRING_SHORT , testProperty "scanl" $ \f (toElem -> c) x -> B.unpack (B.scanl ((toElem .) . f) c x) === scanl ((toElem .) . f) c (B.unpack x) , testProperty "scanl foldl" $ @@ -477,14 +503,17 @@ \f x -> B.unpack (B.scanr1 ((toElem .) . f) x) === scanr1 ((toElem .) . f) (B.unpack x) , testProperty "scanr1 empty" $ \f -> B.scanr1 f B.empty === B.empty +#endif -#ifndef BYTESTRING_LAZY +#if !defined(BYTESTRING_LAZY) && !defined(BYTESTRING_SHORT) , testProperty "sort" $ \x -> B.unpack (B.sort x) === List.sort (B.unpack x) #endif +#ifndef BYTESTRING_SHORT , testProperty "intersperse" $ \(toElem -> c) x -> B.unpack (B.intersperse c x) === List.intersperse c (B.unpack x) +#endif , testProperty "intercalate" $ \(Sqrt x) (Sqrt ys) -> B.unpack (B.intercalate x ys) === List.intercalate (B.unpack x) (map B.unpack ys) , testProperty "intercalate 'c' [x,y]" $ @@ -492,6 +521,7 @@ , testProperty "intercalate split" $ \(toElem -> c) x -> B.intercalate (B.singleton c) (B.split c x) === x +#ifndef BYTESTRING_SHORT , testProperty "mapAccumL" $ \f (toElem -> c) x -> second B.unpack (B.mapAccumL ((second toElem .) . f) c x) === List.mapAccumL ((second toElem .) . f) c (B.unpack x) @@ -507,6 +537,7 @@ \f x y -> B.unpack (B.packZipWith ((toElem .) . f) x y) === zipWith ((toElem .) . f) (B.unpack x) (B.unpack y) , testProperty "unzip" $ \(fmap (toElem *** toElem) -> xs) -> (B.unpack *** B.unpack) (B.unzip xs) === unzip xs +#endif , testProperty "index" $ \(NonNegative n) x -> fromIntegral n < B.length x ==> B.index x (fromIntegral n) === B.unpack x !! n @@ -580,11 +611,13 @@ unsnoc [] = Nothing unsnoc xs = Just (init xs, last xs) +#ifndef BYTESTRING_SHORT findIndexEnd :: (a -> Bool) -> [a] -> Maybe Int findIndexEnd f xs = fmap (\n -> length xs - 1 - n) (List.findIndex f (reverse xs)) elemIndexEnd :: Eq a => a -> [a] -> Maybe Int elemIndexEnd c xs = fmap (\n -> length xs - 1 - n) (List.elemIndex c (reverse xs)) +#endif stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] stripSuffix x y = fmap reverse (List.stripPrefix (reverse x) (reverse y)) diff --git a/tests/Properties/ShortByteString.hs b/tests/Properties/ShortByteString.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ShortByteString.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} + +#define BYTESTRING_SHORT + +#include "ByteString.hs" diff --git a/tests/QuickCheckUtils.hs b/tests/QuickCheckUtils.hs --- a/tests/QuickCheckUtils.hs +++ b/tests/QuickCheckUtils.hs @@ -19,6 +19,7 @@ import System.IO import Foreign.C (CChar) +import qualified Data.ByteString.Short as SB import qualified Data.ByteString as P import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Internal as L (checkInvariant,ByteString(..)) @@ -101,3 +102,16 @@ arbitrary = Sqrt <$> sized (\n -> resize (round @Double $ sqrt $ fromIntegral @Int n) arbitrary) shrink = map Sqrt . shrink . unSqrt + + +sizedShortByteString :: Int -> Gen SB.ShortByteString +sizedShortByteString n = do m <- choose(0, n) + fmap SB.pack $ vectorOf m arbitrary + +instance Arbitrary SB.ShortByteString where + arbitrary = sized sizedShortByteString + shrink = map SB.pack . shrink . SB.unpack + +instance CoArbitrary SB.ShortByteString where + coarbitrary s = coarbitrary (SB.unpack s) +