diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for shortbytestring + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2021 Julian Ospald + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,16 @@ +module Main (main) where + + +import GHC.IO.Encoding +import Test.Tasty.Bench + +import qualified Short.BenchAll as SBA +import qualified Short.Word16.BenchAll as SWBA + + + +main :: IO () +main = do + setLocaleEncoding utf8 + defaultMain + (SBA.benchmarks ++ SWBA.benchmarks) diff --git a/bench/Short/BenchAll.hs b/bench/Short/BenchAll.hs new file mode 100644 --- /dev/null +++ b/bench/Short/BenchAll.hs @@ -0,0 +1,134 @@ +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MagicHash #-} + +module Short.BenchAll (benchmarks) where + +import Short.BenchIndices + +import Data.Monoid +import Data.String +import Test.Tasty.Bench +import Prelude hiding (words) + +import qualified "bytestring" Data.ByteString.Char8 as S8 +import "shortbytestring" Data.ByteString.Short ( ShortByteString ) +import qualified "shortbytestring" Data.ByteString.Short as S + + +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 :: ShortByteString +byteStringData = S.pack $ map fromIntegral intData + +-- benchmark wrappers +--------------------- + +{-# INLINE benchB' #-} +benchB' :: String -> a -> (a -> ShortByteString) -> Benchmark +benchB' name x b = bench name $ whnf (S.length . b) x + + +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 + +w :: Int -> Word8 +w = fromIntegral + +hashWord8 :: Word8 -> Word8 +hashWord8 = fromIntegral . hashInt . fromIntegral + +partitionStrict :: (Word8 -> Bool) -> Benchmarkable +partitionStrict p = nf (S.partition p) . randomStrict $ mkStdGen 98423098 + where randomStrict = fst . S.unfoldrN 10000 (Just . random) + + +-- benchmarks +------------- + + +foldInputs :: [ShortByteString] +foldInputs = map (\k -> S.pack $ if (k :: Int) <= 6 then take (2 ^ k) [32..95] else concat (replicate (2 ^ (k - 6)) [32..95])) [0..16] + +largeTraversalInput :: ShortByteString +largeTraversalInput = S.concat (replicate 10 byteStringData) + +smallTraversalInput :: ShortByteString +smallTraversalInput = S.toShort . S8.unlines $ map S8.pack ["The quick brown fox"] + +benchmarks :: [ Benchmark ] +benchmarks = + [ bgroup "AFP.Data.ByteString.Short" + [ bgroup "Small payload" + [ benchB' "mempty" () (const mempty) + , benchB' "UTF-8 String (naive)" "hello world\0" fromString + , benchB' "String (naive)" "hello world!" fromString + ] + ] + + , 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 "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 "filter" $ map (\s -> bench (show $ S.length s) $ + nf (S.filter odd) s) foldInputs + ] + , bgroup "findIndex_" + [ 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 + ] + , benchIndices + ] diff --git a/bench/Short/BenchIndices.hs b/bench/Short/BenchIndices.hs new file mode 100644 --- /dev/null +++ b/bench/Short/BenchIndices.hs @@ -0,0 +1,82 @@ +-- | +-- Copyright : (c) 2020 Peter Duchovni +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Peter Duchovni +-- +-- Benchmark elemIndex, findIndex, elemIndices, and findIndices + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PackageImports #-} + +module Short.BenchIndices (benchIndices) where + +import Data.Maybe (listToMaybe) +import Data.Monoid +import "shortbytestring" Data.ByteString.Short ( ShortByteString ) +import Test.Tasty.Bench +import Prelude hiding (words) +import Data.Word (Word8) + +import qualified "shortbytestring" Data.ByteString.Short as S + + +------------------------------------------------------------------------------ +-- Benchmark +------------------------------------------------------------------------------ + +-- ASCII \n to ensure no typos +nl :: Word8 +nl = 0xa +{-# INLINE nl #-} + +-- non-inlined equality test +nilEq :: Word8 -> Word8 -> Bool +{-# NOINLINE nilEq #-} +nilEq = (==) + +-- lines of 200 letters from a to e, followed by repeated letter f +absurdlong :: 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 + +benchIndices :: Benchmark +benchIndices = bgroup "Short.BenchIndices" + [ bgroup "ByteString strict first index" $ + [ bench "FindIndices" $ nf (listToMaybe . S.findIndices (== nl)) absurdlong + , bench "ElemIndices" $ nf (listToMaybe . S.elemIndices nl) absurdlong + , bench "FindIndex" $ nf (S.findIndex (== nl)) absurdlong + , bench "ElemIndex" $ nf (S.elemIndex nl) absurdlong + ] + , bgroup "ByteString strict second index" $ + [ bench "FindIndices" $ nf (listToMaybe . 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 "ByteString index equality inlining" $ + [ bench "FindIndices/inlined" $ nf (S.findIndices (== nl)) absurdlong + , bench "FindIndices/non-inlined" $ nf (S.findIndices (nilEq nl)) absurdlong + , bench "FindIndex/inlined" $ nf (S.findIndex (== nl)) absurdlong + , bench "FindIndex/non-inlined" $ nf (S.findIndex (nilEq nl)) absurdlong + ] + ] + +bench_find_index_second :: 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 #-} diff --git a/bench/Short/Word16/BenchAll.hs b/bench/Short/Word16/BenchAll.hs new file mode 100644 --- /dev/null +++ b/bench/Short/Word16/BenchAll.hs @@ -0,0 +1,135 @@ +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MagicHash #-} + +module Short.Word16.BenchAll (benchmarks) where + +import Short.Word16.BenchIndices + +import Data.Monoid +import Data.String +import Test.Tasty.Bench +import Prelude hiding (words) + +import qualified "bytestring" Data.ByteString.Char8 as S8 +import "shortbytestring" Data.ByteString.Short ( ShortByteString ) +import qualified "shortbytestring" Data.ByteString.Short.Word16 as S + + +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 :: ShortByteString +byteStringData = S.pack $ map fromIntegral intData + + +-- benchmark wrappers +--------------------- + + +{-# INLINE benchB' #-} +benchB' :: String -> a -> (a -> ShortByteString) -> Benchmark +benchB' name x b = bench name $ whnf (S.length . b) x + + +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 + +w :: Int -> Word16 +w = fromIntegral + +hashWord16 :: Word16 -> Word16 +hashWord16 = fromIntegral . hashInt . fromIntegral + +partitionStrict :: (Word16 -> Bool) -> Benchmarkable +partitionStrict p = nf (S.partition p) . randomStrict $ mkStdGen 98423098 + where randomStrict = fst . S.unfoldrN 10000 (Just . random) + + +-- benchmarks +------------- + + +foldInputs :: [ShortByteString] +foldInputs = map (\k -> S.pack $ if (k :: Int) <= 6 then take (2 ^ k) [32..95] else concat (replicate (2 ^ (k - 6)) [32..95])) [0..16] + +largeTraversalInput :: ShortByteString +largeTraversalInput = S.concat (replicate 10 byteStringData) + +smallTraversalInput :: ShortByteString +smallTraversalInput = S.toShort . S8.unlines $ map S8.pack ["The quick brown fox"] + +benchmarks :: [ Benchmark ] +benchmarks = + [ bgroup "AFP.Data.ByteString.Short.Word16" + [ bgroup "Small payload" + [ benchB' "mempty" () (const mempty) + , benchB' "UTF-8 String (naive)" "hello world\0" fromString + , benchB' "String (naive)" "hello world!" fromString + ] + ] + + , bgroup "partition" + [ + bgroup "strict" + [ + bench "mostlyTrueFast" $ partitionStrict (< (w 225)) + , bench "mostlyFalseFast" $ partitionStrict (< (w 10)) + , bench "balancedFast" $ partitionStrict (< (w 128)) + + , bench "mostlyTrueSlow" $ partitionStrict (\x -> hashWord16 x < w 225) + , bench "mostlyFalseSlow" $ partitionStrict (\x -> hashWord16 x < w 10) + , bench "balancedSlow" $ partitionStrict (\x -> hashWord16 x < w 128) + ] + ] + , bgroup "folds" + [ bgroup "foldl'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldl' (\acc x -> acc + fromIntegral x) (0 :: Int)) s) foldInputs + , bgroup "foldr'" $ map (\s -> bench (show $ S.length s) $ + nf (S.foldr' (\x acc -> fromIntegral x + acc) (0 :: Int)) s) foldInputs + , bgroup "filter" $ map (\s -> bench (show $ S.length s) $ + nf (S.filter odd) s) foldInputs + ] + , bgroup "findIndex_" + [ 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 + ] + , benchIndices + ] diff --git a/bench/Short/Word16/BenchIndices.hs b/bench/Short/Word16/BenchIndices.hs new file mode 100644 --- /dev/null +++ b/bench/Short/Word16/BenchIndices.hs @@ -0,0 +1,82 @@ +-- | +-- Copyright : (c) 2020 Peter Duchovni +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Peter Duchovni +-- +-- Benchmark elemIndex, findIndex, elemIndices, and findIndices + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PackageImports #-} + +module Short.Word16.BenchIndices (benchIndices) where + +import Data.Maybe (listToMaybe) +import Data.Monoid +import "shortbytestring" Data.ByteString.Short ( ShortByteString ) +import Test.Tasty.Bench +import Prelude hiding (words) +import Data.Word (Word16) + +import qualified "shortbytestring" Data.ByteString.Short.Word16 as S + + +------------------------------------------------------------------------------ +-- Benchmark +------------------------------------------------------------------------------ + +-- ASCII \n to ensure no typos +nl :: Word16 +nl = 0xa +{-# INLINE nl #-} + +-- non-inlined equality test +nilEq :: Word16 -> Word16 -> Bool +{-# NOINLINE nilEq #-} +nilEq = (==) + +-- lines of 200 letters from a to e, followed by repeated letter f +absurdlong :: 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 + +benchIndices :: Benchmark +benchIndices = bgroup "Short.Word16.BenchIndices" + [ bgroup "ByteString strict first index" $ + [ bench "FindIndices" $ nf (listToMaybe . S.findIndices (== nl)) absurdlong + , bench "ElemIndices" $ nf (listToMaybe . S.elemIndices nl) absurdlong + , bench "FindIndex" $ nf (S.findIndex (== nl)) absurdlong + , bench "ElemIndex" $ nf (S.elemIndex nl) absurdlong + ] + , bgroup "ByteString strict second index" $ + [ bench "FindIndices" $ nf (listToMaybe . 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 "ByteString index equality inlining" $ + [ bench "FindIndices/inlined" $ nf (S.findIndices (== nl)) absurdlong + , bench "FindIndices/non-inlined" $ nf (S.findIndices (nilEq nl)) absurdlong + , bench "FindIndex/inlined" $ nf (S.findIndex (== nl)) absurdlong + , bench "FindIndex/non-inlined" $ nf (S.findIndex (nilEq nl)) absurdlong + ] + ] + +bench_find_index_second :: 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 #-} diff --git a/lib/Data/ByteString/Short.hs b/lib/Data/ByteString/Short.hs new file mode 100644 --- /dev/null +++ b/lib/Data/ByteString/Short.hs @@ -0,0 +1,1006 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE PackageImports #-} + +module Data.ByteString.Short + ( + -- * Types + ShortByteString, + + -- * Introducing and eliminating 'ShortByteString's + empty, + singleton, + pack, + unpack, + fromShort, + toShort, + + -- * Basic interface + snoc, + cons, + append, + last, + tail, + head, + init, + 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 conversions + -- ** Packing 'CString's and pointers + packCString, + packCStringLen, + + -- ** Using ShortByteStrings as 'CString's + useAsCString, + useAsCStringLen, + ) +where + +import Prelude hiding + ( all + , any + , break + , concat + , drop + , dropWhile + , elem + , filter + , foldl + , foldl1 + , foldr + , foldr1 + , head + , init + , last + , length + , map + , reverse + , null + , replicate + , span + , splitAt + , tail + , take + , takeWhile + ) + +import Data.ByteString.Short.Internal +import "bytestring" Data.ByteString.Short + ( ShortByteString + , empty + , fromShort + , index +#if MIN_VERSION_bytestring(0,11,0) + , indexMaybe + , (!?) +#endif + , length + , null + , pack + , toShort + , unpack + ) +import "bytestring" Data.ByteString.Short.Internal + ( createFromPtr ) +import Data.Word8 + + +import qualified "bytestring" Data.ByteString.Short as BS +import qualified "bytestring" Data.ByteString.Short.Internal as BS + + +import Data.ByteString.Internal + ( memcmp ) +import Foreign.Marshal.Alloc + ( mallocBytes, free ) +import GHC.List (errorEmptyList) +import Data.Bifunctor + ( first, bimap ) +import qualified Data.List as List +import qualified Data.Foldable as Foldable +import Foreign.Ptr + +import GHC.Exts +import GHC.IO +import GHC.ST + ( ST (ST) ) +import GHC.Word +import Data.Bits + ( FiniteBits (finiteBitSize), shiftL, (.&.), (.|.) ) + + +-- $setup +-- >>> :set -XPackageImports +-- >>> import "shortbytestring" Data.ByteString.Short + +-- ----------------------------------------------------------------------------- +-- Introducing and eliminating 'ShortByteString's + +-- | /O(1)/ Convert a 'Word8' into a 'ShortByteString' +singleton :: Word8 -> ShortByteString +singleton = \w -> create 1 (\mba -> writeWord8Array mba 0 w) +{-# INLINE [1] singleton #-} + + +-- --------------------------------------------------------------------- +-- 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 +snoc :: ShortByteString -> Word8 -> ShortByteString +snoc = \sbs c -> let l = BS.length sbs + nl = l + 1 + in create nl $ \mba -> do + copyByteArray (asBA sbs) 0 mba 0 nl + writeWord8Array mba l c +{-# INLINE snoc #-} + +-- | /O(n)/ 'cons' is analogous to (:) for lists. +-- +-- Note: copies the entire byte array +cons :: Word8 -> ShortByteString -> ShortByteString +cons c = \sbs -> let l = BS.length sbs + 1 + in create l $ \mba -> do + writeWord8Array mba 0 c + copyByteArray (asBA sbs) 0 mba 1 l +{-# INLINE cons #-} + +-- | /O(n)/ Append two ShortByteStrings +append :: ShortByteString -> ShortByteString -> ShortByteString +append = mappend +{-# INLINE append #-} + +-- | /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. +last :: ShortByteString -> Word8 +last = \sbs -> case BS.null sbs of + True -> error "empty ShortByteString" + False -> indexWord8Array (asBA sbs) (BS.length sbs - 1) +{-# INLINE last #-} + +-- | /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. +-- +-- Note: copies the entire byte array +tail :: ShortByteString -> ShortByteString +tail = \sbs -> + let l = BS.length sbs + nl = l - 1 + in case BS.null sbs of + True -> error "empty ShortByteString" + False -> create nl $ \mba -> copyByteArray (asBA sbs) 1 mba 0 nl +{-# INLINE tail #-} + +-- | /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. +head :: ShortByteString -> Word8 +head = \sbs -> case BS.null sbs of + True -> error "empty ShortByteString" + False -> indexWord8Array (asBA sbs) 0 +{-# INLINE head #-} + +-- | /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. +-- +-- Note: copies the entire byte array +init :: ShortByteString -> ShortByteString +init = \sbs -> + let l = BS.length sbs + nl = l - 1 + in case BS.null sbs of + True -> error "empty ShortByteString" + False -> create nl $ \mba -> copyByteArray (asBA sbs) 0 mba 0 nl +{-# INLINE init #-} + + +-- --------------------------------------------------------------------- +-- Transformations + +-- | /O(n)/ 'map' @f xs@ is the ShortByteString obtained by applying @f@ to each +-- element of @xs@. +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. +reverse :: ShortByteString -> ShortByteString +reverse = \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 (l - 1 - i) w + go ba mba (i+1) l + + +-- | /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. +intercalate :: ShortByteString -> [ShortByteString] -> ShortByteString +intercalate s = concat . List.intersperse s +{-# INLINE [1] 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. +-- +foldl :: (a -> Word8 -> a) -> a -> ShortByteString -> a +foldl f v = List.foldl f v . unpack +{-# INLINE foldl #-} + +-- | 'foldl'' is like 'foldl', but strict in the accumulator. +-- +foldl' :: (a -> Word8 -> a) -> a -> ShortByteString -> a +foldl' f v = List.foldl' f v . unpack +{-# INLINE foldl' #-} + +-- | '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. +foldr :: (Word8 -> a -> a) -> a -> ShortByteString -> a +foldr f v = List.foldr f v . unpack +{-# INLINE foldr #-} + +-- | 'foldr'' is like 'foldr', but strict in the accumulator. +foldr' :: (Word8 -> a -> a) -> a -> ShortByteString -> a +foldr' k v = Foldable.foldr' k v . unpack +{-# INLINE foldr' #-} + +-- | 'foldl1' is a variant of 'foldl' that has no starting value +-- argument, and thus must be applied to non-empty 'ShortByteString's. +-- An exception will be thrown in the case of an empty ShortByteString. +foldl1 :: (Word8 -> Word8 -> Word8) -> ShortByteString -> Word8 +foldl1 k = List.foldl1 k . unpack +{-# INLINE foldl1 #-} + +-- | 'foldl1'' is like 'foldl1', but strict in the accumulator. +-- An exception will be thrown in the case of an empty ShortByteString. +foldl1' :: (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. +foldr1 :: (Word8 -> Word8 -> Word8) -> ShortByteString -> Word8 +foldr1 k = List.foldr1 k . unpack +{-# INLINE foldr1 #-} + +-- | 'foldr1'' is a variant of 'foldr1', but is strict in the +-- accumulator. +foldr1' :: (Word8 -> Word8 -> Word8) -> ShortByteString -> Word8 +foldr1' k = \sbs -> if null sbs then errorEmptyList "foldr1'" else foldr' k (last sbs) (init sbs) +{-# INLINE foldr1' #-} + + + +-- --------------------------------------------------------------------- +-- Special folds + +-- | /O(n)/ Applied to a predicate and a 'ShortByteString', 'all' determines +-- if all elements of the 'ShortByteString' satisfy the predicate. +all :: (Word8 -> Bool) -> ShortByteString -> Bool +all k = \sbs -> + let l = BS.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. +any :: (Word8 -> Bool) -> ShortByteString -> Bool +any k = \sbs -> + let l = BS.length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = False + | otherwise = k (w n) || go (n + 1) + in go 0 +{-# INLINE [1] any #-} + + +-- | /O(n)/ Concatenate a list of ShortByteStrings. +concat :: [ShortByteString] -> ShortByteString +concat = mconcat + + +-- --------------------------------------------------------------------- +-- 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 +take :: Int -> ShortByteString -> ShortByteString +take = \n -> \sbs -> + let len = min (BS.length sbs) (max 0 n) + in create len $ \mba -> copyByteArray (asBA sbs) 0 mba 0 len +{-# INLINE take #-} + +-- | Similar to 'P.takeWhile', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate. +takeWhile :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +takeWhile f ps = take (findIndexOrLength (not . f) ps) ps +{-# INLINE [1] takeWhile #-} + +-- | /O(1)/ @'takeEnd' n xs@ is equivalent to @'drop' ('length' xs - n) xs@. +-- Takes @n@ elements from end of bytestring. +-- +-- >>> takeEnd 3 "abcdefg" +-- "efg" +-- >>> takeEnd 0 "abcdefg" +-- "" +-- >>> takeEnd 4 "abc" +-- "abc" +takeEnd :: Int -> ShortByteString -> ShortByteString +takeEnd n sbs + | n >= length sbs = sbs + | n <= 0 = empty + | otherwise = drop (length sbs - n) sbs +{-# INLINE takeEnd #-} + +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate. +-- +-- @'takeWhileEnd' p@ is equivalent to @'reverse' . 'takeWhile' p . 'reverse'@. +takeWhileEnd :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +takeWhileEnd f ps = drop (findFromEndUntil (not . f) ps) ps +{-# INLINE takeWhileEnd #-} + +-- | /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 +drop :: Int -> ShortByteString -> ShortByteString +drop = \n -> \sbs -> + let len = BS.length sbs + newLen = max 0 (len - max 0 n) + in if | n <= 0 -> sbs + | n >= len -> empty + | otherwise -> create newLen $ \mba -> copyByteArray (asBA sbs) n mba 0 newLen +{-# INLINE drop #-} + +-- | /O(1)/ @'dropEnd' n xs@ is equivalent to @'take' ('length' xs - n) xs@. +-- Drops @n@ elements from end of bytestring. +-- +-- >>> dropEnd 3 "abcdefg" +-- "abcd" +-- >>> dropEnd 0 "abcdefg" +-- "abcdefg" +-- >>> dropEnd 4 "abc" +-- "" +dropEnd :: Int -> ShortByteString -> ShortByteString +dropEnd n sbs + | n <= 0 = sbs + | n >= length sbs = empty + | otherwise = take (length sbs - n) sbs + +{-# INLINE dropEnd #-} +-- | Similar to 'P.dropWhile', +-- drops the longest (possibly empty) prefix of elements +-- satisfying the predicate and returns the remainder. +-- +-- Note: copies the entire byte array +dropWhile :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +dropWhile f = \ps -> drop (findIndexOrLength (not . f) ps) ps + +-- | Similar to 'P.dropWhileEnd', +-- drops the longest (possibly empty) suffix of elements +-- satisfying the predicate and returns the remainder. +-- +-- @'dropWhileEnd' p@ is equivalent to @'reverse' . 'dropWhile' p . 'reverse'@. +-- +-- @since 0.10.12.0 +dropWhileEnd :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +dropWhileEnd f = \ps -> take (findFromEndUntil (not . f) ps) ps +{-# INLINE dropWhileEnd #-} + +-- | Returns the longest (possibly empty) suffix of elements which __do not__ +-- satisfy the predicate and the remainder of the string. +-- +-- 'breakEnd' @p@ is equivalent to @'spanEnd' (not . p)@ and to @('takeWhileEnd' (not . p) &&& 'dropWhileEnd' (not . p))@. +breakEnd :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +breakEnd p = \sbs -> splitAt (findFromEndUntil p sbs) sbs +{-# INLINE breakEnd #-} + +-- | Similar to 'P.break', +-- returns the longest (possibly empty) prefix of elements which __do not__ +-- satisfy the predicate and the remainder of the string. +-- +-- 'break' @p@ is equivalent to @'span' (not . p)@ and to @('takeWhile' (not . p) &&& 'dropWhile' (not . p))@. +break :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +break = \p -> \ps -> case findIndexOrLength p ps of n -> (take n ps, drop n ps) +{-# INLINE [1] break #-} + +-- | Similar to 'P.span', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate and the remainder of the string. +-- +-- 'span' @p@ is equivalent to @'break' (not . p)@ and to @('takeWhile' p &&& 'dropWhile' p)@. +-- +span :: (Word8 -> Bool) -> 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) ps +-- > == +-- > let (x, y) = span (not . isSpace) (reverse ps) in (reverse y, reverse x) +-- +spanEnd :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +spanEnd p = \ps -> splitAt (findFromEndUntil (not.p) ps) ps + +-- | /O(n)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@. +-- +-- Note: copies the substrings +splitAt :: Int -> ShortByteString -> (ShortByteString, ShortByteString) +splitAt n = \xs -> if + | n <= 0 -> (mempty, xs) + | n >= BS.length xs -> (xs, mempty) + | otherwise -> (take n xs, drop n xs) + +-- | /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 +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 [""] +-- +splitWith :: (Word8 -> Bool) -> ShortByteString -> [ShortByteString] +splitWith p = \sbs -> if + | BS.null sbs -> [] + | otherwise -> go sbs + where + go sbs' + | BS.null sbs' = [mempty] + | otherwise = + case break p sbs' of + (a, b) + | BS.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'. +stripSuffix :: ShortByteString -> ShortByteString -> Maybe ShortByteString +stripSuffix sbs1 sbs2 = do + let l1 = BS.length sbs1 + l2 = BS.length sbs2 + if | l1 == 0 -> Just sbs2 + | l2 < l1 -> Nothing + | otherwise -> unsafeDupablePerformIO $ do + p1 <- mallocBytes l1 + p2 <- mallocBytes l2 + BS.copyToPtr sbs1 0 p1 l1 + BS.copyToPtr sbs2 0 p2 l2 + i <- memcmp p1 (p2 `plusPtr` (l2 - l1)) (fromIntegral l1) + if i == 0 + then do + sbs <- createFromPtr p2 (fromIntegral (l2 - l1)) + free p1 + free p2 + return $! Just sbs + else do + free p1 + free p2 + return 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'. +stripPrefix :: ShortByteString -> ShortByteString -> Maybe ShortByteString +stripPrefix sbs1 sbs2 = do + let l1 = BS.length sbs1 + l2 = BS.length sbs2 + if | l1 == 0 -> Just sbs2 + | l2 < l1 -> Nothing + | otherwise -> unsafeDupablePerformIO $ do + p1 <- mallocBytes l1 + p2 <- mallocBytes l2 + BS.copyToPtr sbs1 0 p1 l1 + BS.copyToPtr sbs2 0 p2 l2 + i <- memcmp p1 p2 (fromIntegral l1) + if i == 0 + then do + sbs <- createFromPtr (p2 `plusPtr` l1) (l2 - l1) + free p1 + free p2 + return $! Just sbs + else do + free p1 + free p2 + return 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 +-- +-- This implementation uses @memset(3)@ +replicate :: Int -> Word8 -> ShortByteString +replicate w c + | w <= 0 = empty + | otherwise = create w (\mba -> go mba 0) + where + go mba ix + | ix < 0 || ix >= w = pure () + | otherwise = writeWord8Array mba ix c >> go mba (ix + 1) +{-# INLINE replicate #-} + +-- | /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'. +-- +-- Examples: +-- +-- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0 +-- > == pack [0, 1, 2, 3, 4, 5] +-- +unfoldr :: (a -> Maybe (Word8, a)) -> a -> ShortByteString +unfoldr f x0 = packBytesRev $ go x0 mempty + where + go x words' = case f x of + Nothing -> words' + Just (w, x') -> go x' (w:words') +{-# INLINE unfoldr #-} + +-- | /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. +-- +-- This function is not efficient. It will build a full list of @[Word8]@ +-- before creating a 'ShortByteString'. +-- +-- The following equation relates 'unfoldrN' and 'unfoldr': +-- +-- > fst (unfoldrN n f s) == take n (unfoldr f s) +-- +unfoldrN :: Int -> (a -> Maybe (Word8, a)) -> a -> (ShortByteString, Maybe a) +unfoldrN i f x0 = first packBytesRev $ go (i - 1) x0 mempty + where + go i' x words' + | i' < 0 = (words', Just x) + | otherwise = case f x of + Nothing -> (words', Nothing) + Just (w, x') -> go (i' - 1) x' (w:words') +{-# INLINE unfoldrN #-} + + +-- -------------------------------------------------------------------- +-- Predicates + +-- | Check whether one string is a substring of another. +isInfixOf :: ShortByteString -> ShortByteString -> Bool +isInfixOf p s = BS.null p || not (BS.null $ snd $ breakSubstring p s) + +-- |/O(n)/ The 'isPrefixOf' function takes two ShortByteStrings and returns 'True' +isPrefixOf :: ShortByteString -> ShortByteString -> Bool +isPrefixOf sbs1 sbs2 = do + let l1 = BS.length sbs1 + l2 = BS.length sbs2 + if | l1 == 0 -> True + | l2 < l1 -> False + | otherwise -> unsafeDupablePerformIO $ do + p1 <- mallocBytes l1 + p2 <- mallocBytes l2 + BS.copyToPtr sbs1 0 p1 l1 + BS.copyToPtr sbs2 0 p2 l2 + i <- memcmp p1 p2 (fromIntegral l1) + free p1 + free p2 + return $! 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 +isSuffixOf :: ShortByteString -> ShortByteString -> Bool +isSuffixOf sbs1 sbs2 = do + let l1 = BS.length sbs1 + l2 = BS.length sbs2 + if | l1 == 0 -> True + | l2 < l1 -> False + | otherwise -> unsafeDupablePerformIO $ do + p1 <- mallocBytes l1 + p2 <- mallocBytes l2 + BS.copyToPtr sbs1 0 p1 l1 + BS.copyToPtr sbs2 0 p2 l2 + i <- memcmp p1 (p2 `plusPtr` (l2 - l1)) (fromIntegral l1) + free p1 + free p2 + return $! 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. +-- +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 -> (mempty,) + 1 -> breakByte (head pat) + _ -> if lp * 8 <= finiteBitSize (0 :: Word) + then shift + else karpRabin + where + lp = BS.length pat + karpRabin :: ShortByteString -> (ShortByteString, ShortByteString) + karpRabin src + | BS.length src < lp = (src,mempty) + | 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 . BS.unsafeIndex src + search !hs !i + | hp == hs && pat == take lp b = u + | BS.length src <= i = (src, mempty) -- 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 + | BS.length src < lp = (src, mempty) + | 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 + | BS.length src <= i = (src, mempty) + | otherwise = search w' (i + 1) + where + b = fromIntegral (BS.unsafeIndex src i) + w' = mask' .&. ((w `shiftL` 8) .|. b) + {-# INLINE shift #-} + + +-- -------------------------------------------------------------------- +-- Searching ShortByteString + +-- | /O(n)/ 'elem' is the 'ShortByteString' membership predicate. +elem :: Word8 -> ShortByteString -> Bool +elem c = \ps -> case elemIndex c ps of Nothing -> False ; _ -> True + +-- | /O(n)/ 'filter', applied to a predicate and a ByteString, +-- returns a ByteString containing those characters that satisfy the +-- predicate. +filter :: (Word8 -> Bool) -> ShortByteString -> ShortByteString +filter k = \sbs -> if + | null sbs -> sbs + | otherwise -> pack . List.filter k . unpack $ sbs +{-# INLINE filter #-} + +-- | /O(n)/ The 'find' function takes a predicate and a ByteString, +-- and returns the first element in matching the predicate, or 'Nothing' +-- if there is no such element. +-- +-- > find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing +-- +find :: (Word8 -> Bool) -> ShortByteString -> Maybe Word8 +find f = \p -> case findIndex f p of + Just n -> Just (p `index` n) + _ -> Nothing +{-# INLINE find #-} + +-- | /O(n)/ The 'partition' function takes a predicate a ByteString and returns +-- the pair of ByteStrings with elements which do and do not satisfy the +-- predicate, respectively; i.e., +-- +-- > partition p bs == (filter p xs, filter (not . p) xs) +-- +partition :: (Word8 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +partition f = \s -> if + | null s -> (s, s) + | otherwise -> bimap pack pack . List.partition f . unpack $ s + + +#if !MIN_VERSION_bytestring(0,11,0) +-- | /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 $! indexWord8Array (asBA 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 (!?) #-} +#endif + + +-- -------------------------------------------------------------------- +-- 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. +elemIndex :: Word8 -> ShortByteString -> Maybe Int +elemIndex k = findIndex (==k) +{-# INLINE elemIndex #-} + +-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning +-- the indices of all elements equal to the query element, in ascending order. +elemIndices :: Word8 -> ShortByteString -> [Int] +elemIndices k = findIndices (==k) + +-- | count returns the number of times its argument appears in the ShortByteString +count :: Word8 -> ShortByteString -> Int +count w = List.length . elemIndices 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. +findIndex :: (Word8 -> Bool) -> ShortByteString -> Maybe Int +findIndex k = \sbs -> + let l = BS.length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = Nothing + | k (w n) = Just n + | otherwise = go (n + 1) + in go 0 +{-# INLINE findIndex #-} + + +-- | /O(n)/ The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending order. +findIndices :: (Word8 -> Bool) -> ShortByteString -> [Int] +findIndices k = \sbs -> + let l = BS.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 +{-# INLINE [1] findIndices #-} + + +-- -------------------------------------------------------------------- +-- Internal + +-- Find from the end of the string using predicate +findFromEndUntil :: (Word8 -> Bool) -> ShortByteString -> Int +findFromEndUntil k sbs = go (BS.length sbs - 1) + where + ba = asBA sbs + w = indexWord8Array ba + go !n | n < 0 = 0 + | k (w n) = n + 1 + | otherwise = go (n - 1) +{-# INLINE findFromEndUntil #-} + +findIndexOrLength :: (Word8 -> Bool) -> ShortByteString -> Int +findIndexOrLength k sbs = go 0 + where + l = BS.length sbs + ba = asBA sbs + w = indexWord8Array ba + go !n | n >= l = l + | k (w n) = n + | otherwise = go (n + 1) +{-# INLINE findIndexOrLength #-} + + +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 p = case elemIndex c p of + Nothing -> (p, mempty) + Just n -> (take n p, drop n p) +{-# INLINE breakByte #-} + +indexWord8Array :: BA -> Int -> Word8 +indexWord8Array (BA# ba#) (I# i#) = W8# (indexWord8Array# ba# i#) + +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', () #) + diff --git a/lib/Data/ByteString/Short/Decode.hs b/lib/Data/ByteString/Short/Decode.hs new file mode 100644 --- /dev/null +++ b/lib/Data/ByteString/Short/Decode.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE RankNTypes #-} + +module Data.ByteString.Short.Decode (decodeUtf16LE, decodeUtf16LEWith, decodeUtf16LE', decodeUtf16LE'', decodeUtf8, decodeUtf8With, decodeUtf8') where + +import Data.ByteString + ( ByteString ) +import Data.ByteString.Short + ( ShortByteString ) +import Data.Text + ( Text ) +import Data.Text.Encoding.Error + ( OnDecodeError, UnicodeException, strictDecode ) +import Data.Text.Internal.Fusion.Types + ( Step (..), Stream (..) ) +import Data.Text.Internal.Fusion.Size + ( maxSize ) +import Data.Text.Internal.Unsafe.Char + ( unsafeChr, unsafeChr8 ) +import Data.Text.Internal.Unsafe.Shift + ( shiftL, shiftR ) +import Data.Word + ( Word16, Word8 ) + +import Control.Exception + ( evaluate, try ) +import qualified Data.ByteString.Short as BS + ( index, length ) +import qualified Data.Text.Encoding as E +import qualified Data.Text.Internal.Encoding.Utf16 as U16 +import qualified Data.Text.Internal.Encoding.Utf8 as U8 +import GHC.IO + ( unsafeDupablePerformIO ) + + +-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using UTF-8 +-- encoding. +streamUtf8 :: OnDecodeError -> ShortByteString -> Stream Char +streamUtf8 onErr bs = Stream next 0 (maxSize l) + where + l = BS.length bs + next i + | i >= l = Done + | U8.validate1 x1 = Yield (unsafeChr8 x1) (i+1) + | i+1 < l && U8.validate2 x1 x2 = Yield (U8.chr2 x1 x2) (i+2) + | i+2 < l && U8.validate3 x1 x2 x3 = Yield (U8.chr3 x1 x2 x3) (i+3) + | i+3 < l && U8.validate4 x1 x2 x3 x4 = Yield (U8.chr4 x1 x2 x3 x4) (i+4) + | otherwise = decodeError "streamUtf8" "UTF-8" onErr (Just x1) (i+1) + where + x1 = idx i + x2 = idx (i + 1) + x3 = idx (i + 2) + x4 = idx (i + 3) + idx = BS.index bs +{-# INLINE [0] streamUtf8 #-} + +-- | /O(n)/ Convert a 'ShortByteString' into a 'Stream Char', using little +-- endian UTF-16 encoding. +streamUtf16LE :: OnDecodeError -> ShortByteString -> Stream Char +streamUtf16LE onErr bs = Stream next 0 (maxSize (l `shiftR` 1)) + where + l = BS.length bs + {-# INLINE next #-} + next i + | i >= l = Done + | i+1 < l && U16.validate1 x1 = Yield (unsafeChr x1) (i+2) + | i+3 < l && U16.validate2 x1 x2 = Yield (U16.chr2 x1 x2) (i+4) + | otherwise = decodeError "streamUtf16LE" "UTF-16LE" onErr Nothing (i+1) + where + x1 = idx i + (idx (i + 1) `shiftL` 8) + x2 = idx (i + 2) + (idx (i + 3) `shiftL` 8) + idx = fromIntegral . BS.index bs :: Int -> Word16 +{-# INLINE [0] streamUtf16LE #-} + +-- | Decode text from little endian UTF-16 encoding. +decodeUtf16LEWith :: OnDecodeError -> ShortByteString -> String +decodeUtf16LEWith onErr bs = unstream (streamUtf16LE onErr bs) +{-# INLINE decodeUtf16LEWith #-} + +-- | Decode text from little endian UTF-16 encoding. +-- +-- If the input contains any invalid little endian UTF-16 data, an +-- exception will be thrown. For more control over the handling of +-- invalid data, use 'decodeUtf16LEWith'. +decodeUtf16LE :: ShortByteString -> String +decodeUtf16LE = decodeUtf16LEWith strictDecode +{-# INLINE decodeUtf16LE #-} + +-- | Decode text from little endian UTF-16 encoding. +decodeUtf8With :: OnDecodeError -> ShortByteString -> String +decodeUtf8With onErr bs = unstream (streamUtf8 onErr bs) +{-# INLINE decodeUtf8With #-} + +-- | Decode text from little endian UTF-16 encoding. +-- +-- If the input contains any invalid little endian UTF-16 data, an +-- exception will be thrown. For more control over the handling of +-- invalid data, use 'decodeUtf16LEWith'. +decodeUtf8 :: ShortByteString -> String +decodeUtf8 = decodeUtf8With strictDecode +{-# INLINE decodeUtf8 #-} + + +decodeError :: forall s. String -> String -> OnDecodeError -> Maybe Word8 + -> s -> Step s Char +decodeError func kind onErr mb i = + case onErr desc mb of + Nothing -> Skip i + Just c -> Yield c i + where desc = "Data.Text.Internal.Encoding.Fusion." ++ func ++ ": Invalid " ++ + kind ++ " stream" + +-- | /O(n)/ Convert a 'Stream Char' into a 'Text'. +unstream :: Stream Char -> String +unstream (Stream next0 s0 _) = go s0 + where + go si = + case next0 si of + Done -> [] + Skip si' -> go si' + Yield c si' -> c : go si' +{-# INLINE [0] unstream #-} + + +-- | Decode a 'ShortByteString' containing UTF-8 encoded text. +-- +-- If the input contains any invalid UTF-8 data, the relevant +-- exception will be returned, otherwise the decoded text. +decodeUtf8' :: ShortByteString -> Either UnicodeException String +decodeUtf8' = unsafeDupablePerformIO . try . evaluate . decodeUtf8With strictDecode +{-# INLINE decodeUtf8' #-} + + +-- | Decode a 'ShortByteString' containing UTF-16 encoded text. +-- +-- If the input contains any invalid UTF-16 data, the relevant +-- exception will be returned, otherwise the decoded text. +decodeUtf16LE' :: ShortByteString -> Either UnicodeException String +decodeUtf16LE' = unsafeDupablePerformIO . try . evaluate . decodeUtf16LEWith strictDecode +{-# INLINE decodeUtf16LE' #-} + + +-- | Decode a 'ByteString' containing UTF-16 encoded text. +-- +-- If the input contains any invalid UTF-16 data, the relevant +-- exception will be returned, otherwise the decoded text. +decodeUtf16LE'' :: ByteString -> Either UnicodeException Text +decodeUtf16LE'' = unsafeDupablePerformIO . try . evaluate . E.decodeUtf16LEWith strictDecode +{-# INLINE decodeUtf16LE'' #-} + diff --git a/lib/Data/ByteString/Short/Encode.hs b/lib/Data/ByteString/Short/Encode.hs new file mode 100644 --- /dev/null +++ b/lib/Data/ByteString/Short/Encode.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE RankNTypes #-} + +module Data.ByteString.Short.Encode (encodeUtf8, encodeUtf16LE) where + +import Data.Bits + ( shiftR, (.&.) ) +import Data.ByteString.Short + ( ShortByteString ) +import Data.Char + ( ord ) +import Data.Word + ( Word8 ) + +import qualified Data.ByteString.Short as BS + ( pack ) + + +encodeUtf8 :: String -> ShortByteString +encodeUtf8 = BS.pack . encode + where + encode :: String -> [Word8] + encode = concatMap encodeChar + + encodeChar :: Char -> [Word8] + encodeChar = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) + , 0x80 + oc .&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) + , 0x80 + ((oc `shiftR` 6) .&. 0x3f) + , 0x80 + oc .&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `shiftR` 18) + , 0x80 + ((oc `shiftR` 12) .&. 0x3f) + , 0x80 + ((oc `shiftR` 6) .&. 0x3f) + , 0x80 + oc .&. 0x3f + ] +{-# INLINE encodeUtf8 #-} + + +encodeUtf16LE :: String -> ShortByteString +encodeUtf16LE = BS.pack . encode + where + encode :: String -> [Word8] + encode = concatMap encodeChar + + encodeChar :: Char -> [Word8] + encodeChar = map fromIntegral . go . ord + where + go oc + | oc < 0x10000 = [ oc, oc `shiftR` 8 ] + | otherwise = + let m = oc - 0x10000 + in [ m `shiftR` 10 + , (m `shiftR` 18) + 0xD8 + , m .&. 0x3FF + , ((m .&. 0x3FF) `shiftR` 8) + 0xDC ] +{-# INLINE encodeUtf16LE #-} diff --git a/lib/Data/ByteString/Short/Internal.hs b/lib/Data/ByteString/Short/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Data/ByteString/Short/Internal.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UnboxedTuples #-} + +module Data.ByteString.Short.Internal + ( create + , asBA + , BA(..) + , MBA(..) + , newPinnedByteArray + , newByteArray + , copyByteArray + , unsafeFreezeByteArray + , useAsCString + , useAsCStringLen + , useAsCWString + , useAsCWStringLen + , packCString + , packCStringLen + , packCWString + , packCWStringLen + , newCWString + ) + +where + +import Prelude hiding + ( length ) +import GHC.Exts +import GHC.ST + ( ST (ST), runST ) +import Data.Word +import Foreign.C.String hiding (newCWString) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Array (mallocArray0) +import Foreign.Storable (pokeByteOff) +import "bytestring" Data.ByteString.Short.Internal +import Control.Exception ( throwIO ) +#if MIN_VERSION_bytestring(0,10,9) +import Data.ByteString.Internal (c_strlen) +#else +import Foreign.C.Types +#endif + + +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 #-} + + +asBA :: ShortByteString -> BA +asBA (SBS ba#) = BA# ba# + + + +data BA = BA# ByteArray# +data MBA s = MBA# (MutableByteArray# s) + + +newPinnedByteArray :: Int -> ST s (MBA s) +newPinnedByteArray (I# len#) = + ST $ \s -> case newPinnedByteArray# len# s of + (# s', mba# #) -> (# s', MBA# mba# #) + +newByteArray :: Int -> ST s (MBA s) +newByteArray (I# len#) = + ST $ \s -> case newByteArray# len# s of + (# s', mba# #) -> (# s', MBA# mba# #) + +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', () #) + +unsafeFreezeByteArray :: MBA s -> ST s BA +unsafeFreezeByteArray (MBA# mba#) = + ST $ \s -> case unsafeFreezeByteArray# mba# s of + (# s', ba# #) -> (# s', BA# ba# #) + + +-- this is a copy-paste from bytestring +#if !MIN_VERSION_bytestring(0,10,9) +------------------------------------------------------------------------ +-- Primop replacements + +-- --------------------------------------------------------------------- +-- +-- Standard C functions +-- + +foreign import ccall unsafe "string.h strlen" c_strlen + :: CString -> IO CSize + + +-- --------------------------------------------------------------------- +-- +-- Uses our C code +-- + +-- | /O(n)./ Construct a new @ShortByteString@ from a @CString@. The +-- resulting @ShortByteString@ is an immutable copy of the original +-- @CString@, and is managed on the Haskell heap. The original +-- @CString@ must be null terminated. +-- +-- @since 0.10.10.0 +packCString :: CString -> IO ShortByteString +packCString cstr = do + len <- c_strlen cstr + packCStringLen (cstr, fromIntegral len) + +-- | /O(n)./ Construct a new @ShortByteString@ from a @CStringLen@. The +-- resulting @ShortByteString@ is an immutable copy of the original @CStringLen@. +-- The @ShortByteString@ is a normal Haskell value and will be managed on the +-- Haskell heap. +-- +-- @since 0.10.10.0 +packCStringLen :: CStringLen -> IO ShortByteString +packCStringLen (cstr, len) | len >= 0 = createFromPtr cstr len +packCStringLen (_, len) = + moduleErrorIO "packCStringLen" ("negative length: " ++ show len) + +-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a +-- null-terminated @CString@. The @CString@ is a copy and will be freed +-- automatically; it must not be stored or used after the +-- subcomputation finishes. +-- +-- @since 0.10.10.0 +useAsCString :: ShortByteString -> (CString -> IO a) -> IO a +useAsCString bs action = + allocaBytes (l+1) $ \buf -> do + copyToPtr bs 0 buf (fromIntegral l) + pokeByteOff buf l (0::Word8) + action buf + where l = length bs + +-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a @CStringLen@. +-- As for @useAsCString@ this function makes a copy of the original @ShortByteString@. +-- It must not be stored or used after the subcomputation finishes. +-- +-- @since 0.10.10.0 +useAsCStringLen :: ShortByteString -> (CStringLen -> IO a) -> IO a +useAsCStringLen bs action = + allocaBytes l $ \buf -> do + copyToPtr bs 0 buf (fromIntegral l) + action (buf, l) + where l = length bs + + +#endif + + +-- | /O(n)./ Construct a new @ShortByteString@ from a @CWString@. The +-- resulting @ShortByteString@ is an immutable copy of the original +-- @CWString@, and is managed on the Haskell heap. The original +-- @CWString@ must be null terminated. +-- +-- @since 0.10.10.0 +packCWString :: CWString -> IO ShortByteString +packCWString cstr = do + len <- c_strlen (coerce cstr) + packCWStringLen (cstr, fromIntegral len) + +-- | /O(n)./ Construct a new @ShortByteString@ from a @CWStringLen@. The +-- resulting @ShortByteString@ is an immutable copy of the original @CWStringLen@. +-- The @ShortByteString@ is a normal Haskell value and will be managed on the +-- Haskell heap. +-- +-- @since 0.10.10.0 +packCWStringLen :: CWStringLen -> IO ShortByteString +packCWStringLen (cstr, len) | len >= 0 = createFromPtr cstr len +packCWStringLen (_, len) = + moduleErrorIO "packCWStringLen" ("negative length: " ++ show len) + + +-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a +-- null-terminated @CWString@. The @CWString@ is a copy and will be freed +-- automatically; it must not be stored or used after the +-- subcomputation finishes. +-- +-- @since 0.10.10.0 +useAsCWString :: ShortByteString -> (CWString -> IO a) -> IO a +useAsCWString 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 @CWStringLen@. +-- As for @useAsCWString@ 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 +useAsCWStringLen :: ShortByteString -> (CWStringLen -> IO a) -> IO a +useAsCWStringLen bs action = + allocaBytes l $ \buf -> do + copyToPtr bs 0 buf (fromIntegral l) + action (buf, l) + where l = length bs + +-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a @CWStringLen@. +-- As for @useAsCWString@ 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 +newCWString :: ShortByteString -> IO CWString +newCWString bs = do + ptr <- mallocArray0 l + copyToPtr bs 0 ptr (fromIntegral l) + pokeByteOff ptr l (0::Word8) + return ptr + where l = length bs + + + -- --------------------------------------------------------------------- +-- Internal utilities + +moduleErrorIO :: String -> String -> IO a +moduleErrorIO fun msg = throwIO . userError $ moduleErrorMsg fun msg +{-# NOINLINE moduleErrorIO #-} + +moduleErrorMsg :: String -> String -> String +moduleErrorMsg fun msg = "Data.ByteString.Short." ++ fun ++ ':':' ':msg diff --git a/lib/Data/ByteString/Short/Word16.hs b/lib/Data/ByteString/Short/Word16.hs new file mode 100644 --- /dev/null +++ b/lib/Data/ByteString/Short/Word16.hs @@ -0,0 +1,884 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Data.ByteString.Short.Word16 +-- Copyright : © 2021 Julian Ospald +-- License : MIT +-- +-- Maintainer : Julian Ospald +-- Stability : experimental +-- Portability : portable +-- +-- ShortByteStrings encoded as UTF16-LE, suitable for windows FFI calls. +-- +-- Word16s are *always* in BE encoding (both input and output), so e.g. 'pack' +-- takes a list of BE encoded @[Word16]@ and produces a UTF16-LE encoded ShortByteString. +-- +-- Likewise, 'unpack' takes a UTF16-LE encoded ShortByteString and produces a list of BE encoded @[Word16]@. +-- +-- Indices and lengths are always in respect to Word16, not Word8. +-- +-- All functions will error out if the input string is not a valid UTF16 stream (uneven number of bytes). +-- So use this module with caution. +module Data.ByteString.Short.Word16 ( + -- * Types + ShortByteString, + + -- * Introducing and eliminating 'ShortByteString's + empty, + singleton, + pack, + unpack, + fromShort, + toShort, + + -- * Basic interface + snoc, + cons, + append, + last, + tail, + head, + init, + 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, + takeWhile, + takeWhileEnd, + drop, + dropEnd, + dropWhile, + dropWhileEnd, + breakEnd, + break, + span, + spanEnd, + splitAt, + split, + splitWith, + stripSuffix, + stripPrefix, + + -- * Predicates + isInfixOf, + isPrefixOf, + isSuffixOf, + + -- * 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 'CString's and pointers + packCWString, + packCWStringLen, + newCWString, + + -- ** Using ShortByteStrings as 'CString's + useAsCWString, + useAsCWStringLen + ) +where + +import Data.ByteString.Short + ( append, intercalate, isInfixOf, isPrefixOf, isSuffixOf, stripSuffix, stripPrefix, fromShort, toShort, concat ) +import Data.ByteString.Short.Internal +import Data.Word16 +#if !MIN_VERSION_base(4,13,0) +import Data.Monoid ((<>)) +#endif +import Data.Bifunctor + ( first, bimap ) +import Prelude hiding + ( all + , any + , reverse + , break + , concat + , drop + , dropWhile + , elem + , filter + , foldl + , foldl1 + , foldr + , foldr1 + , head + , init + , last + , length + , map + , null + , replicate + , span + , splitAt + , tail + , take + , takeWhile + ) +import GHC.List (errorEmptyList) +import qualified Data.Foldable as Foldable +import Data.ByteString.Short + ( ShortByteString + , empty + , null + ) +import GHC.Exts +import GHC.Word +import GHC.ST + ( ST (ST) ) + +import qualified "bytestring" Data.ByteString.Short.Internal as BS +import qualified Data.List as List + + +-- ----------------------------------------------------------------------------- +-- Introducing and eliminating 'ShortByteString's + +-- | /O(1)/ Convert a 'Word16' into a 'ShortByteString' +singleton :: Word16 -> ShortByteString +singleton = \w -> create 2 (\mba -> writeWord16Array mba 0 w) +{-# INLINE [1] singleton #-} + + +-- | /O(n)/. Convert a list into a 'ShortByteString' +pack :: [Word16] -> ShortByteString +pack = packBytes + + +-- | /O(n)/. Convert a 'ShortByteString' into a list. +unpack :: ShortByteString -> [Word16] +unpack = unpackBytes . assertEven + + +-- --------------------------------------------------------------------- +-- Basic interface + +-- | This is the number of 'Word16', not 'Word8'. +length :: ShortByteString -> Int +length = (`div` 2) . BS.length . assertEven + +infixr 5 `cons` --same as list (:) +infixl 5 `snoc` + +-- | /O(n)/ Append a Word16 to the end of a 'ShortByteString' +-- +-- Note: copies the entire byte array +snoc :: ShortByteString -> Word16 -> ShortByteString +snoc = \(assertEven -> sbs) c -> let l = BS.length sbs + nl = l + 2 + in create nl $ \mba -> do + copyByteArray (asBA sbs) 0 mba 0 nl + writeWord16Array mba l c +{-# INLINE snoc #-} + +-- | /O(n)/ 'cons' is analogous to (:) for lists. +-- +-- Note: copies the entire byte array +cons :: Word16 -> ShortByteString -> ShortByteString +cons c = \(assertEven -> sbs) -> let l = BS.length sbs + nl = l + 2 + in create nl $ \mba -> do + writeWord16Array mba 0 c + copyByteArray (asBA sbs) 0 mba 2 nl +{-# INLINE cons #-} + +-- | /O(1)/ Extract the last element of a ShortByteString, which must be finite and at least one Word16. +-- An exception will be thrown in the case of an empty ShortByteString. +last :: ShortByteString -> Word16 +last = \(assertEven -> sbs) -> + indexWord16Array (asBA sbs) (BS.length sbs - 2) +{-# INLINE last #-} + +-- | /O(n)/ Extract the elements after the head of a ShortByteString, which must at least one Word16. +-- An exception will be thrown in the case of an empty ShortByteString. +-- +-- Note: copies the entire byte array +tail :: ShortByteString -> ShortByteString +tail = \(assertEven -> sbs) -> + let l = BS.length sbs + nl = l - 2 + in if + | l <= 0 -> sbs + | l <= 2 -> empty + | otherwise -> create nl $ \mba -> copyByteArray (asBA sbs) 2 mba 0 nl +{-# INLINE tail #-} + +-- | /O(1)/ Extract the first element of a ShortByteString, which must be at least one Word16. +-- An exception will be thrown in the case of an empty ShortByteString. +head :: ShortByteString -> Word16 +head = \(assertEven -> sbs) -> indexWord16Array (asBA sbs) 0 +{-# INLINE head #-} + +-- | /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. +-- +-- Note: copies the entire byte array +init :: ShortByteString -> ShortByteString +init = \(assertEven -> sbs) -> + let l = BS.length sbs + nl = l - 2 + in if + | l <= 0 -> sbs + | l <= 2 -> empty + | otherwise -> create nl $ \mba -> copyByteArray (asBA sbs) 0 mba 0 nl +{-# INLINE init #-} + + +-- --------------------------------------------------------------------- +-- Transformations + +-- | /O(n)/ 'map' @f xs@ is the ShortByteString obtained by applying @f@ to each +-- element of @xs@. +map :: (Word16 -> Word16) -> ShortByteString -> ShortByteString +map f = \(assertEven -> sbs) -> + let l = BS.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 = indexWord16Array ba i + writeWord16Array mba i (f w) + go ba mba (i+2) l + +-- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order. +reverse :: ShortByteString -> ShortByteString +reverse = \(assertEven -> sbs) -> + let l = BS.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 = indexWord16Array ba i + writeWord16Array mba (l - 2 - i) w + go ba mba (i+2) l + + +-- --------------------------------------------------------------------- +-- Special folds + +-- | /O(n)/ Applied to a predicate and a 'ShortByteString', 'all' determines +-- if all elements of the 'ShortByteString' satisfy the predicate. +all :: (Word16 -> Bool) -> ShortByteString -> Bool +all k = \(assertEven -> sbs) -> + let l = BS.length sbs + ba = asBA sbs + w = indexWord16Array ba + go !n | n >= l = True + | otherwise = k (w n) && go (n + 2) + in go 0 + + +-- | /O(n)/ Applied to a predicate and a ByteString, 'any' determines if +-- any element of the 'ByteString' satisfies the predicate. +any :: (Word16 -> Bool) -> ShortByteString -> Bool +any k = \(assertEven -> sbs) -> + let l = BS.length sbs + ba = asBA sbs + w = indexWord16Array ba + go !n | n >= l = False + | otherwise = k (w n) || go (n + 2) + in go 0 +{-# INLINE [1] any #-} + + +-- --------------------------------------------------------------------- +-- 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 +replicate :: Int -> Word16 -> ShortByteString +replicate w c + | w <= 0 = empty + | otherwise = create (w * 2) (\mba -> go mba 0) + where + go mba ix + | ix < 0 || ix >= w * 2 = pure () + | otherwise = writeWord16Array mba ix c >> go mba (ix + 2) +{-# INLINE replicate #-} + +-- | /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 @[Word16]@ +-- and run the generator until it returns `Nothing`, otherwise recurse infinitely, +-- then finally create a 'ShortByteString'. +-- +-- Examples: +-- +-- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0 +-- > == pack [0, 1, 2, 3, 4, 5] +-- +unfoldr :: (a -> Maybe (Word16, a)) -> a -> ShortByteString +unfoldr f x0 = packBytesRev $ go x0 mempty + where + go x words' = case f x of + Nothing -> words' + Just (w, x') -> go x' (w:words') +{-# INLINE unfoldr #-} + +-- | /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. +-- +-- This function is not efficient. It will build a full list of @[Word8]@ +-- before creating a 'ShortByteString'. +-- +-- The following equation relates 'unfoldrN' and 'unfoldr': +-- +-- > fst (unfoldrN n f s) == take n (unfoldr f s) +-- +unfoldrN :: Int -> (a -> Maybe (Word16, a)) -> a -> (ShortByteString, Maybe a) +unfoldrN i f x0 = first packBytesRev $ go (i - 1) x0 mempty + where + go i' x words' + | i' < 0 = (words', Just x) + | otherwise = case f x of + Nothing -> (words', Nothing) + Just (w, x') -> go (i' - 1) x' (w:words') +{-# INLINE unfoldrN #-} + + +-- -------------------------------------------------------------------- +-- Predicates + + + +-- --------------------------------------------------------------------- +-- 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 +take :: Int -- ^ number of Word16 + -> ShortByteString + -> ShortByteString +take = \n -> \(assertEven -> sbs) -> + let len = min (length sbs) (max 0 n) + len8 = len * 2 + in create len8 $ \mba -> copyByteArray (asBA sbs) 0 mba 0 len8 +{-# INLINE take #-} + + +-- | /O(1)/ @'takeEnd' n xs@ is equivalent to @'drop' ('length' xs - n) xs@. +-- Takes @n@ elements from end of bytestring. +-- +-- >>> takeEnd 3 "a\NULb\NULc\NULd\NULe\NULf\NULg\NUL" +-- "e\NULf\NULg\NUL" +-- >>> takeEnd 0 "a\NULb\NULc\NULd\NULe\NULf\NULg\NUL" +-- "" +-- >>> takeEnd 4 "a\NULb\NULc\NUL" +-- "a\NULb\NULc\NUL" +takeEnd :: Int -> ShortByteString -> ShortByteString +takeEnd n sbs + | n >= length sbs = sbs + | n <= 0 = empty + | otherwise = drop (length sbs - n) sbs +{-# INLINE takeEnd #-} + +-- | Similar to 'P.takeWhile', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate. +takeWhile :: (Word16 -> Bool) -> ShortByteString -> ShortByteString +takeWhile f ps = take (findIndexOrLength (not . f) ps) ps +{-# INLINE [1] takeWhile #-} + +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate. +-- +-- @'takeWhileEnd' p@ is equivalent to @'reverse' . 'takeWhile' p . 'reverse'@. +takeWhileEnd :: (Word16 -> Bool) -> ShortByteString -> ShortByteString +takeWhileEnd f ps = drop (findFromEndUntil (not . f) ps) ps +{-# INLINE takeWhileEnd #-} + + +-- | /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 +drop :: Int -> ShortByteString -> ShortByteString +drop = \n -> \(assertEven -> sbs) -> + let len = length sbs + newLen = max 0 (len - max 0 n) + in if | n <= 0 -> sbs + | n >= length sbs -> empty + | otherwise -> create (newLen * 2) $ \mba -> copyByteArray (asBA sbs) (n * 2) mba 0 (newLen * 2) +{-# INLINE drop #-} + +-- | /O(1)/ @'dropEnd' n xs@ is equivalent to @'take' ('length' xs - n) xs@. +-- Drops @n@ elements from end of bytestring. +-- +-- >>> dropEnd 3 "a\NULb\NULc\NULd\NULe\NULf\NULg\NUL" +-- "a\NULb\NULc\NULd\NUL" +-- >>> dropEnd 0 "a\NULb\NULc\NULd\NULe\NULf\NULg\NUL" +-- "a\NULb\NULc\NULd\NULe\NULf\NULg\NUL" +-- >>> dropEnd 4 "a\NULb\NULc\NUL" +-- "" +dropEnd :: Int -> ShortByteString -> ShortByteString +dropEnd n sbs + | n <= 0 = sbs + | n >= length sbs = empty + | otherwise = take (length sbs - n) sbs + +-- | Similar to 'P.dropWhile', +-- drops the longest (possibly empty) prefix of elements +-- satisfying the predicate and returns the remainder. +-- +-- Note: copies the entire byte array +dropWhile :: (Word16 -> Bool) -> ShortByteString -> ShortByteString +dropWhile f = \(assertEven -> ps) -> drop (findIndexOrLength (not . f) ps) ps + +-- | Similar to 'P.dropWhileEnd', +-- drops the longest (possibly empty) suffix of elements +-- satisfying the predicate and returns the remainder. +-- +-- @'dropWhileEnd' p@ is equivalent to @'reverse' . 'dropWhile' p . 'reverse'@. +-- +-- @since 0.10.12.0 +dropWhileEnd :: (Word16 -> Bool) -> ShortByteString -> ShortByteString +dropWhileEnd f = \(assertEven -> ps) -> take (findFromEndUntil (not . f) ps) ps +{-# INLINE dropWhileEnd #-} + +-- | Returns the longest (possibly empty) suffix of elements which __do not__ +-- satisfy the predicate and the remainder of the string. +-- +-- 'breakEnd' @p@ is equivalent to @'spanEnd' (not . p)@ and to @('takeWhileEnd' (not . p) &&& 'dropWhileEnd' (not . p))@. +breakEnd :: (Word16 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +breakEnd p = \(assertEven -> sbs) -> splitAt (findFromEndUntil p sbs) sbs +{-# INLINE breakEnd #-} + +-- | Similar to 'P.break', +-- returns the longest (possibly empty) prefix of elements which __do not__ +-- satisfy the predicate and the remainder of the string. +-- +-- 'break' @p@ is equivalent to @'span' (not . p)@ and to @('takeWhile' (not . p) &&& 'dropWhile' (not . p))@. +break :: (Word16 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +break = \p -> \(assertEven -> ps) -> case findIndexOrLength p ps of n -> (take n ps, drop n ps) +{-# INLINE [1] break #-} + +-- | Similar to 'P.span', +-- returns the longest (possibly empty) prefix of elements +-- satisfying the predicate and the remainder of the string. +-- +-- 'span' @p@ is equivalent to @'break' (not . p)@ and to @('takeWhile' p &&& 'dropWhile' p)@. +-- +span :: (Word16 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +span p = break (not . p) . assertEven + +-- | Returns the longest (possibly empty) suffix of elements +-- satisfying the predicate and the remainder of the string. +-- +-- 'spanEnd' @p@ is equivalent to @'breakEnd' (not . p)@ and to @('takeWhileEnd' p &&& 'dropWhileEnd' p)@. +-- +-- We have +-- +-- > spanEnd (not . isSpace) "x y z" == ("x y ", "z") +-- +-- and +-- +-- > spanEnd (not . isSpace) ps +-- > == +-- > let (x, y) = span (not . isSpace) (reverse ps) in (reverse y, reverse x) +-- +spanEnd :: (Word16 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +spanEnd p = \(assertEven -> ps) -> splitAt (findFromEndUntil (not.p) ps) ps + +-- | /O(n)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@. +-- +-- Note: copies the substrings +splitAt :: Int -- ^ number of Word16 + -> ShortByteString + -> (ShortByteString, ShortByteString) +splitAt n = \(assertEven -> xs) -> if + | n <= 0 -> (mempty, xs) + | n >= BS.length xs * 2 -> (xs, mempty) + | otherwise -> (take n xs, drop n xs) + +-- | /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 +split :: Word16 -> ShortByteString -> [ShortByteString] +split w = splitWith (== w) . assertEven + + +-- | /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 [""] +-- +splitWith :: (Word16 -> Bool) -> ShortByteString -> [ShortByteString] +splitWith p = \(assertEven -> sbs) -> if + | BS.null sbs -> [] + | otherwise -> go sbs + where + go sbs' + | BS.null sbs' = [mempty] + | otherwise = + case break p sbs' of + (a, b) + | BS.null b -> [a] + | otherwise -> a : go (tail b) + + +-- --------------------------------------------------------------------- +-- 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. +-- +foldl :: (a -> Word16 -> a) -> a -> ShortByteString -> a +foldl f v = List.foldl f v . unpack . assertEven +{-# INLINE foldl #-} + +-- | 'foldl'' is like 'foldl', but strict in the accumulator. +-- +foldl' :: (a -> Word16 -> a) -> a -> ShortByteString -> a +foldl' f v = List.foldl' f v . unpack . assertEven +{-# INLINE foldl' #-} + +-- | '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. +foldr :: (Word16 -> a -> a) -> a -> ShortByteString -> a +foldr f v = List.foldr f v . unpack . assertEven +{-# INLINE foldr #-} + +-- | 'foldr'' is like 'foldr', but strict in the accumulator. +foldr' :: (Word16 -> a -> a) -> a -> ShortByteString -> a +foldr' k v = Foldable.foldr' k v . unpack . assertEven +{-# INLINE foldr' #-} + +-- | 'foldl1' is a variant of 'foldl' that has no starting value +-- argument, and thus must be applied to non-empty 'ShortByteString's. +-- An exception will be thrown in the case of an empty ShortByteString. +foldl1 :: (Word16 -> Word16 -> Word16) -> ShortByteString -> Word16 +foldl1 k = List.foldl1 k . unpack . assertEven +{-# INLINE foldl1 #-} + +-- | 'foldl1'' is like 'foldl1', but strict in the accumulator. +-- An exception will be thrown in the case of an empty ShortByteString. +foldl1' :: (Word16 -> Word16 -> Word16) -> ShortByteString -> Word16 +foldl1' k = List.foldl1' k . unpack . assertEven + +-- | '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. +foldr1 :: (Word16 -> Word16 -> Word16) -> ShortByteString -> Word16 +foldr1 k = List.foldr1 k . unpack . assertEven +{-# INLINE foldr1 #-} + +-- | 'foldr1'' is a variant of 'foldr1', but is strict in the +-- accumulator. +foldr1' :: (Word16 -> Word16 -> Word16) -> ShortByteString -> Word16 +foldr1' k = \(assertEven -> sbs) -> if null sbs then errorEmptyList "foldr1'" else foldr' k (last sbs) (init sbs) + + +-- -------------------------------------------------------------------- +-- Searching ShortByteString + +-- | /O(1)/ 'ShortByteString' index (subscript) operator, starting from 0. +index :: ShortByteString -> Int -> Word16 +index = \(assertEven -> sbs) i -> + let ba = asBA sbs + w = indexWord16Array ba + in if + | i >= 0 && i < length sbs -> w (i * 2) + | otherwise -> error $ "Data.ByteString.Short.Word16.index: error in array index; " + ++ show i ++ " not in range [0.." ++ show (length sbs) ++ ")" + +-- | /O(1)/ 'ShortByteString' index, starting from 0, that returns 'Just' if: +-- +-- > 0 <= n < length bs +-- +-- @since 0.11.0.0 +indexMaybe :: ShortByteString -> Int -> Maybe Word16 +indexMaybe = \(assertEven -> sbs) i -> + let ba = asBA sbs + w = indexWord16Array ba + in if + | i >= 0 && i < length sbs -> Just (w (i * 2)) + | 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 Word16 +(!?) = indexMaybe +{-# INLINE (!?) #-} + +-- | /O(n)/ 'elem' is the 'ShortByteString' membership predicate. +elem :: Word16 -> ShortByteString -> Bool +elem c = \ps -> case elemIndex c ps of Nothing -> False ; _ -> True + +-- | /O(n)/ 'filter', applied to a predicate and a ByteString, +-- returns a ByteString containing those characters that satisfy the +-- predicate. +filter :: (Word16 -> Bool) -> ShortByteString -> ShortByteString +filter k = \sbs -> if + | null sbs -> sbs + | otherwise -> pack . List.filter k . unpack . assertEven $ sbs +{-# INLINE filter #-} + +-- | /O(n)/ The 'find' function takes a predicate and a ByteString, +-- and returns the first element in matching the predicate, or 'Nothing' +-- if there is no such element. +-- +-- > find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing +-- +find :: (Word16 -> Bool) -> ShortByteString -> Maybe Word16 +find f = List.find f . unpack . assertEven +{-# INLINE find #-} + +-- | /O(n)/ The 'partition' function takes a predicate a ByteString and returns +-- the pair of ByteStrings with elements which do and do not satisfy the +-- predicate, respectively; i.e., +-- +-- > partition p bs == (filter p xs, filter (not . p) xs) +-- +partition :: (Word16 -> Bool) -> ShortByteString -> (ShortByteString, ShortByteString) +partition f = \s -> if + | null s -> (s, s) + | otherwise -> bimap pack pack . List.partition f . unpack . assertEven $ s + +-- -------------------------------------------------------------------- +-- 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. +elemIndex :: Word16 -> ShortByteString -> Maybe Int +elemIndex k = findIndex (==k) +{-# INLINE elemIndex #-} + +-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning +-- the indices of all elements equal to the query element, in ascending order. +elemIndices :: Word16 -> ShortByteString -> [Int] +elemIndices k = findIndices (==k) + +-- | count returns the number of times its argument appears in the ShortByteString +count :: Word16 -> ShortByteString -> Int +count w = List.length . elemIndices 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. +findIndex :: (Word16 -> Bool) -> ShortByteString -> Maybe Int +findIndex k = \sbs -> + let l = BS.length sbs + ba = asBA sbs + w = indexWord16Array ba + go !n | n >= l = Nothing + | k (w n) = Just (n `div` 2) + | otherwise = go (n + 2) + in go 0 +{-# INLINE findIndex #-} + +-- | /O(n)/ The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending order. +findIndices :: (Word16 -> Bool) -> ShortByteString -> [Int] +findIndices k = \sbs -> + let l = BS.length sbs + ba = asBA sbs + w = indexWord16Array ba + go !n | n >= l = [] + | k (w n) = (n `div` 2) : go (n + 2) + | otherwise = go (n + 2) + in go 0 +{-# INLINE [1] findIndices #-} + + +-- -------------------------------------------------------------------- +-- Internal + +-- | This isn't strictly Word16 array write. Instead it's two consecutive Word8 array +-- writes to avoid endianness issues due to primops doing automatic alignment based +-- on host platform. We want to always write LE to the byte array. +writeWord16Array :: MBA s + -> Int -- ^ Word8 index (not Word16) + -> Word16 + -> ST s () +writeWord16Array (MBA# mba#) (I# i#) (W16# w#) = + case encodeWord16LE# w# of + (# lsb#, msb# #) -> + (ST $ \s -> case writeWord8Array# mba# i# lsb# s of + s' -> (# s', () #)) >> + (ST $ \s -> case writeWord8Array# mba# (i# +# 1#) msb# s of + s' -> (# s', () #)) + +-- | This isn't strictly Word16 array read. Instead it's two Word8 array reads +-- to avoid endianness issues due to primops doing automatic alignment based +-- on host platform. We expect the byte array to be LE always. +indexWord16Array :: BA + -> Int -- ^ Word8 index (not Word16) + -> Word16 +indexWord16Array (BA# ba#) (I# i#) = + case (# indexWord8Array# ba# i#, indexWord8Array# ba# (i# +# 1#) #) of + (# lsb#, msb# #) -> W16# ((decodeWord16LE# (# lsb#, msb# #))) + + +packBytes :: [Word16] -> ShortByteString +packBytes cs = packLenBytes (List.length cs) cs + +packLenBytes :: Int -> [Word16] -> ShortByteString +packLenBytes len ws0 = + create (len * 2) (\mba -> go mba 0 ws0) + where + go :: MBA s -> Int -> [Word16] -> ST s () + go !_ !_ [] = return () + go !mba !i (w:ws) = do + writeWord16Array mba i w + go mba (i+2) ws + +packBytesRev :: [Word16] -> ShortByteString +packBytesRev cs = packLenBytesRev ((List.length cs) * 2) cs + +packLenBytesRev :: Int -> [Word16] -> ShortByteString +packLenBytesRev len ws0 = + create len (\mba -> go mba len ws0) + where + go :: MBA s -> Int -> [Word16] -> ST s () + go !_ !_ [] = return () + go !mba !i (w:ws) = do + writeWord16Array mba (i - 2) w + go mba (i - 2) ws + + +unpackBytes :: ShortByteString -> [Word16] +unpackBytes sbs = go len [] + where + len = BS.length sbs + go !i !acc + | i < 1 = acc + | otherwise = let !w = indexWord16Array (asBA sbs) (i - 2) + in go (i - 2) (w:acc) + +-- Returns the index of the first match or the length of the whole +-- bytestring if nothing matched. +findIndexOrLength :: (Word16 -> Bool) -> ShortByteString -> Int +findIndexOrLength k sbs = go 0 + where + l = BS.length sbs + ba = asBA sbs + w = indexWord16Array ba + go !n | n >= l = l `div` 2 + | k (w n) = n `div` 2 + | otherwise = go (n + 2) +{-# INLINE findIndexOrLength #-} + + +-- | Returns the length of the substring matching, not the index. +-- If no match, returns 0. +findFromEndUntil :: (Word16 -> Bool) -> ShortByteString -> Int +findFromEndUntil k sbs = go (BS.length sbs - 2) + where + ba = asBA sbs + w = indexWord16Array ba + go !n | n < 0 = 0 + | k (w n) = (n `div` 2) + 1 + | otherwise = go (n - 2) +{-# INLINE findFromEndUntil #-} + + +assertEven :: ShortByteString -> ShortByteString +assertEven sbs@(BS.SBS barr#) + | even (I# (sizeofByteArray# barr#)) = sbs + | otherwise = error ("Uneven number of bytes: " <> show (BS.length sbs) <> ". This is not a Word16 bytestream.") + + + +encodeWord16LE# :: Word# -- ^ Word16 + -> (# Word#, Word# #) -- ^ Word8 (LSB, MSB) +encodeWord16LE# x# = (# (x# `and#` int2Word# 0xff#) + , ((x# `and#` int2Word# 0xff00#) `shiftRL#` 8#) #) + +decodeWord16LE# :: (# Word#, Word# #) -- ^ Word8 (LSB, MSB) + -> Word# -- ^ Word16 +decodeWord16LE# (# lsb#, msb# #) = ((msb# `shiftL#` 8#) `or#` lsb#) + diff --git a/shortbytestring.cabal b/shortbytestring.cabal new file mode 100644 --- /dev/null +++ b/shortbytestring.cabal @@ -0,0 +1,93 @@ +cabal-version: 3.0 +name: shortbytestring +version: 0.1.0.0 +license: MIT +license-file: LICENSE +maintainer: hasufell@posteo.de +author: Julian Ospald +bug-reports: https://github.com/hasufell/shortbytestring/issues +synopsis: Additional ShortByteString API +description: + Additional ShortByteString API, as well as a Word16 based UTF-16LE module. + +tested-with: + GHC ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.4 + || ==8.10.6 + || ==9.0.1 + +category: System +extra-doc-files: CHANGELOG.md +extra-source-files: tests/Properties/ByteString/Common.hs + +library + exposed-modules: + Data.ByteString.Short + Data.ByteString.Short.Decode + Data.ByteString.Short.Encode + Data.ByteString.Short.Internal + Data.ByteString.Short.Word16 + + hs-source-dirs: lib + default-language: Haskell2010 + build-depends: + , base >=4.9.1.0 && <5 + , bytestring ^>=0.10.8.1 + , exceptions ^>=0.10 + , primitive ^>=0.7 + , template-haskell >=2.10 && <2.20 + , text >=1.2.3.0 && <1.2.6 + , word16 + , word8 ^>=0.1 + + x-docspec-extra-packages: QuickCheck + +benchmark bench + main-is: Bench.hs + other-modules: + Short.BenchAll + Short.BenchIndices + Short.Word16.BenchAll + Short.Word16.BenchIndices + + type: exitcode-stdio-1.0 + hs-source-dirs: bench + default-language: Haskell2010 + ghc-options: -O2 -with-rtsopts=-A32m + build-depends: + , base >=4.9.1.0 && <5 + , bytestring ^>=0.10.8.1 + , deepseq ^>=1.4 + , random ^>=1.1 + , shortbytestring + , tasty-bench ^>=0.3 + +test-suite prop-compiled + type: exitcode-stdio-1.0 + main-is: Properties.hs + other-modules: + Properties.ByteString.Short + Properties.ByteString.Short.Word16 + + hs-source-dirs: tests + include-dirs: tests/Properties + build-depends: + , base >=4.9.1.0 && <5 + , bytestring ^>=0.10.8.1 + , deepseq + , ghc-prim + , shortbytestring + , tasty + , tasty-quickcheck + , word16 + , word8 + + ghc-options: -fwarn-unused-binds -threaded -rtsopts + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/hasufell/shortbytestring.git diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + + +import Test.Tasty + +import qualified Properties.ByteString.Short as PropShort +import qualified Properties.ByteString.Short.Word16 as PropShortWord16 + + +------------------------------------------------------------------------ +-- The entry point + +main :: IO () +main = defaultMain $ testGroup "All" + [ testGroup "StrictWord8" PropShort.tests + , testGroup "StrictWord16" PropShortWord16.tests + ] + diff --git a/tests/Properties/ByteString/Common.hs b/tests/Properties/ByteString/Common.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ByteString/Common.hs @@ -0,0 +1,415 @@ +-- | +-- Module : Properties.ByteString +-- Copyright : (c) Andrew Lelechenko 2021 +-- License : BSD-style + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- We are happy to sacrifice optimizations in exchange for faster compilation, +-- but need to test rewrite rules. As one can check using -ddump-rule-firings, +-- rewrite rules do not fire in -O0 mode, so we use -O1, but disable almost all +-- optimizations. It roughly halves compilation time. +{-# OPTIONS_GHC -O1 -fenable-rewrite-rules + -fmax-simplifier-iterations=1 -fsimplifier-phases=0 + -fno-call-arity -fno-case-merge -fno-cmm-elim-common-blocks -fno-cmm-sink + -fno-cpr-anal -fno-cse -fno-do-eta-reduction -fno-float-in -fno-full-laziness + -fno-loopification -fno-specialise -fno-strictness #-} + +#ifdef WORD8 +module Properties.ByteString.Short (tests) where +import Data.Word8 (isSpace) +import qualified "shortbytestring" Data.ByteString.Short as B +#else +module Properties.ByteString.Short.Word16 (tests) where +import Data.Word16 (isSpace) +import qualified "shortbytestring" Data.ByteString.Short.Word16 as B +#endif +import "shortbytestring" Data.ByteString.Short (ShortByteString) + +import Data.Word + +import Control.Arrow +import Data.Foldable +import Data.List as L +import Data.Semigroup +import Data.Tuple +import Test.Tasty +import Test.Tasty.QuickCheck +import Text.Show.Functions () + +#ifdef WORD16 +toElem :: Word16 -> Word16 +toElem = id + +swapW :: Word16 -> Word16 +swapW = byteSwap16 + +sizedByteString :: Int -> Gen ShortByteString +sizedByteString n = do m <- choose(0, n) + fmap B.pack $ vectorOf m arbitrary + +instance Arbitrary ShortByteString where + arbitrary = do + bs <- sized sizedByteString + n <- choose (0, 2) + return (B.drop n bs) -- to give us some with non-0 offset + +instance CoArbitrary ShortByteString where + coarbitrary s = coarbitrary (B.unpack s) + +#else +toElem :: Word8 -> Word8 +toElem = id + +swapW :: Word8 -> Word8 +swapW = id + + +sizedByteString :: Int -> Gen ShortByteString +sizedByteString n = do m <- choose(0, n) + fmap B.pack $ vectorOf m arbitrary + +instance Arbitrary ShortByteString where + arbitrary = do + bs <- sized sizedByteString + n <- choose (0, 2) + return (B.drop n bs) -- to give us some with non-0 offset + shrink = map B.pack . shrink . B.unpack + +instance CoArbitrary ShortByteString where + coarbitrary s = coarbitrary (B.unpack s) + +#endif + +tests :: [TestTree] +tests = + [ testProperty "pack . unpack" $ + \x -> x === B.pack (B.unpack x) + , testProperty "unpack . pack" $ + \(map toElem -> xs) -> xs === B.unpack (B.pack xs) + , testProperty "read . show" $ + \x -> (x :: ShortByteString) === read (show x) + + , testProperty "==" $ + \x y -> (x == y) === (B.unpack x == B.unpack y) + , testProperty "== refl" $ + \x -> (x :: ShortByteString) == x + , testProperty "== symm" $ + \x y -> ((x :: ShortByteString) == y) === (y == x) + , testProperty "== pack unpack" $ + \x -> x == B.pack (B.unpack x) + + , testProperty "compare" $ + \x y -> compare x y === compare (swapW <$> B.unpack x) (swapW <$> B.unpack y) + , testProperty "compare EQ" $ + \x -> compare (x :: ShortByteString) x == EQ + , testProperty "compare GT" $ + \x (toElem -> c) -> compare (B.snoc x c) x == GT + , testProperty "compare LT" $ + \x (toElem -> c) -> compare x (B.snoc x c) == LT + , testProperty "compare GT empty" $ + \x -> not (B.null x) ==> compare x B.empty == GT + , testProperty "compare LT empty" $ + \x -> not (B.null x) ==> compare B.empty x == LT + , testProperty "compare GT concat" $ + \x y -> not (B.null y) ==> compare (x <> y) x == GT + , testProperty "compare char" $ + \(toElem -> c) (toElem -> d) -> compare (swapW c) (swapW d) == compare (B.singleton c) (B.singleton d) + , testProperty "compare unsigned" $ once $ + compare (B.singleton 255) (B.singleton 127) == GT + + , testProperty "null" $ + \x -> B.null x === null (B.unpack x) + , testProperty "empty 0" $ once $ + B.length B.empty === 0 + , testProperty "empty []" $ once $ + B.unpack B.empty === [] + , testProperty "mempty 0" $ once $ + B.length mempty === 0 + , testProperty "mempty []" $ once $ + B.unpack mempty === [] + + , testProperty "concat" $ + \xs -> B.unpack (B.concat xs) === concat (map B.unpack xs) + , testProperty "concat [x,x]" $ + \x -> B.unpack (B.concat [x, x]) === concat [B.unpack x, B.unpack x] + , testProperty "concat [x,[]]" $ + \x -> B.unpack (B.concat [x, B.empty]) === concat [B.unpack x, []] + , testProperty "mconcat" $ + \xs -> B.unpack (mconcat xs) === mconcat (map B.unpack xs) + , testProperty "mconcat [x,x]" $ + \x -> B.unpack (mconcat [x, x]) === mconcat [B.unpack x, B.unpack x] + , testProperty "mconcat [x,[]]" $ + \x -> B.unpack (mconcat [x, B.empty]) === mconcat [B.unpack x, []] + + , testProperty "null" $ + \x -> B.null x === null (B.unpack x) + , testProperty "reverse" $ + \x -> B.unpack (B.reverse x) === reverse (B.unpack x) + , testProperty "all" $ + \f x -> B.all f x === all f (B.unpack x) + , testProperty "all ==" $ + \(toElem -> c) x -> B.all (== c) x === all (== c) (B.unpack x) + , testProperty "any" $ + \f x -> B.any f x === any f (B.unpack x) + , testProperty "any ==" $ + \(toElem -> c) x -> B.any (== c) x === any (== c) (B.unpack x) + , testProperty "append" $ + \x y -> B.unpack (B.append x y) === B.unpack x ++ B.unpack y + , testProperty "mappend" $ + \x y -> B.unpack (mappend x y) === B.unpack x `mappend` B.unpack y + , testProperty "<>" $ + \x y -> B.unpack (x <> y) === B.unpack x <> B.unpack y + , testProperty "stimes" $ + \(Positive n) x -> stimes (n :: Int) (x :: ShortByteString) === mtimesDefault n x + + , testProperty "break" $ + \f x -> (B.unpack *** B.unpack) (B.break f x) === break f (B.unpack x) + , testProperty "break ==" $ + \(toElem -> c) x -> (B.unpack *** B.unpack) (B.break (== c) x) === break (== c) (B.unpack x) + , testProperty "break /=" $ + \(toElem -> c) x -> (B.unpack *** B.unpack) (B.break (/= c) x) === break (/= c) (B.unpack x) + , testProperty "break span" $ + \f x -> B.break f x === B.span (not . f) x + , testProperty "breakEnd" $ + \f x -> B.breakEnd f x === swap ((B.reverse *** B.reverse) (B.break f (B.reverse x))) + , testProperty "breakEnd" $ + \f x -> B.breakEnd f x === B.spanEnd (not . f) x +#ifndef WORD16 + , testProperty "break breakSubstring" $ + \(toElem -> c) x -> B.break (== c) x === B.breakSubstring (B.singleton c) x + , testProperty "breakSubstring" $ + \x y -> not (B.null x) ==> B.null (snd (B.breakSubstring x y)) === not (B.isInfixOf x y) + , testProperty "breakSubstring empty" $ + \x -> B.breakSubstring B.empty x === (B.empty, x) +#endif + , testProperty "break isSpace" $ + \x -> (B.unpack *** B.unpack) (B.break isSpace x) === break isSpace (B.unpack x) + + , testProperty "singleton" $ + \(toElem -> c) -> B.unpack (B.singleton c) === [c] + , testProperty "cons" $ + \(toElem -> c) x -> B.unpack (B.cons c x) === c : B.unpack x + , testProperty "cons []" $ + \(toElem -> c) -> B.unpack (B.cons c B.empty) === [c] + , testProperty "snoc" $ + \(toElem -> c) x -> B.unpack (B.snoc x c) === B.unpack x ++ [c] + , testProperty "snoc []" $ + \(toElem -> c) -> B.unpack (B.snoc B.empty c) === [c] + + , testProperty "drop" $ + \n x -> B.unpack (B.drop n x) === drop (fromIntegral n) (B.unpack x) + , testProperty "drop 10" $ + \x -> B.unpack (B.drop 10 x) === drop 10 (B.unpack x) + , testProperty "dropWhile" $ + \f x -> B.unpack (B.dropWhile f x) === dropWhile f (B.unpack x) + , testProperty "dropWhile ==" $ + \(toElem -> c) x -> B.unpack (B.dropWhile (== c) x) === dropWhile (== c) (B.unpack x) + , testProperty "dropWhile /=" $ + \(toElem -> c) x -> B.unpack (B.dropWhile (/= c) x) === dropWhile (/= c) (B.unpack x) + , testProperty "dropWhile isSpace" $ + \x -> B.unpack (B.dropWhile isSpace x) === dropWhile isSpace (B.unpack x) + + , testProperty "take" $ + \n x -> B.unpack (B.take n x) === take (fromIntegral n) (B.unpack x) + , testProperty "take 10" $ + \x -> B.unpack (B.take 10 x) === take 10 (B.unpack x) + , testProperty "takeWhile" $ + \f x -> B.unpack (B.takeWhile f x) === takeWhile f (B.unpack x) + , testProperty "takeWhile ==" $ + \(toElem -> c) x -> B.unpack (B.takeWhile (== c) x) === takeWhile (== c) (B.unpack x) + , testProperty "takeWhile /=" $ + \(toElem -> c) x -> B.unpack (B.takeWhile (/= c) x) === takeWhile (/= c) (B.unpack x) + + , testProperty "takeWhile isSpace" $ + \x -> B.unpack (B.takeWhile isSpace x) === takeWhile isSpace (B.unpack x) + + , testProperty "dropEnd" $ + \n x -> B.dropEnd n x === B.take (B.length x - n) x + , testProperty "dropWhileEnd" $ + \f x -> B.dropWhileEnd f x === B.reverse (B.dropWhile f (B.reverse x)) + , testProperty "takeEnd" $ + \n x -> B.takeEnd n x === B.drop (B.length x - n) x + , testProperty "takeWhileEnd" $ + \f x -> B.takeWhileEnd f x === B.reverse (B.takeWhile f (B.reverse x)) + + , testProperty "length" $ + \x -> B.length x === fromIntegral (length (B.unpack x)) + , testProperty "count" $ + \(toElem -> c) x -> B.count c x === fromIntegral (length (elemIndices c (B.unpack x))) + , testProperty "filter" $ + \f x -> B.unpack (B.filter f x) === filter f (B.unpack x) + , testProperty "filter compose" $ + \f g x -> B.filter f (B.filter g x) === B.filter (\c -> f c && g c) x + , testProperty "filter ==" $ + \(toElem -> c) x -> B.unpack (B.filter (== c) x) === filter (== c) (B.unpack x) + , testProperty "filter /=" $ + \(toElem -> c) x -> B.unpack (B.filter (/= c) x) === filter (/= c) (B.unpack x) + , testProperty "partition" $ + \f x -> (B.unpack *** B.unpack) (B.partition f x) === partition f (B.unpack x) + + , testProperty "find" $ + \f x -> B.find f x === find f (B.unpack x) + , testProperty "findIndex" $ + \f x -> B.findIndex f x === fmap fromIntegral (findIndex f (B.unpack x)) + , testProperty "findIndices" $ + \f x -> B.findIndices f x === fmap fromIntegral (findIndices f (B.unpack x)) + , testProperty "findIndices ==" $ + \(toElem -> c) x -> B.findIndices (== c) x === fmap fromIntegral (findIndices (== c) (B.unpack x)) + + , testProperty "elem" $ + \(toElem -> c) x -> B.elem c x === elem c (B.unpack x) + , testProperty "not elem" $ + \(toElem -> c) x -> not (B.elem c x) === notElem c (B.unpack x) + , testProperty "elemIndex" $ + \(toElem -> c) x -> B.elemIndex c x === fmap fromIntegral (elemIndex c (B.unpack x)) + , testProperty "elemIndices" $ + \(toElem -> c) x -> B.elemIndices c x === fmap fromIntegral (elemIndices c (B.unpack x)) + + , testProperty "isPrefixOf" $ + \x y -> B.isPrefixOf x y === isPrefixOf (B.unpack x) (B.unpack y) + , testProperty "stripPrefix" $ + \x y -> fmap B.unpack (B.stripPrefix x y) === stripPrefix (B.unpack x) (B.unpack y) + , testProperty "isSuffixOf" $ + \x y -> B.isSuffixOf x y === isSuffixOf (B.unpack x) (B.unpack y) + , testProperty "stripSuffix" $ + \x y -> fmap B.unpack (B.stripSuffix x y) === stripSuffix (B.unpack x) (B.unpack y) + , testProperty "isInfixOf" $ + \x y -> B.isInfixOf x y === isInfixOf (B.unpack x) (B.unpack y) + + , testProperty "map" $ + \f x -> B.unpack (B.map (toElem . f) x) === map (toElem . f) (B.unpack x) + , testProperty "map compose" $ + \f g x -> B.map (toElem . f) (B.map (toElem . g) x) === B.map (toElem . f . toElem . g) x + , testProperty "replicate" $ + \n (toElem -> c) -> B.unpack (B.replicate (fromIntegral n) c) === replicate n c + , testProperty "replicate 0" $ + \(toElem -> c) -> B.unpack (B.replicate 0 c) === replicate 0 c + + , testProperty "span" $ + \f x -> (B.unpack *** B.unpack) (B.span f x) === span f (B.unpack x) + , testProperty "span ==" $ + \(toElem -> c) x -> (B.unpack *** B.unpack) (B.span (== c) x) === span (== c) (B.unpack x) + , testProperty "span /=" $ + \(toElem -> c) x -> (B.unpack *** B.unpack) (B.span (/= c) x) === span (/= c) (B.unpack x) + , testProperty "spanEnd" $ + \f x -> B.spanEnd f x === swap ((B.reverse *** B.reverse) (B.span f (B.reverse x))) + , testProperty "split" $ + \(toElem -> c) x -> map B.unpack (B.split c x) === split c (B.unpack x) + , testProperty "split empty" $ + \(toElem -> c) -> B.split c B.empty === [] + , testProperty "splitWith" $ + \f x -> map B.unpack (B.splitWith f x) === splitWith f (B.unpack x) + , testProperty "splitWith split" $ + \(toElem -> c) x -> B.splitWith (== c) x === B.split c x + , testProperty "splitWith empty" $ + \f -> B.splitWith f B.empty === [] + , testProperty "splitWith length" $ + \f x -> let splits = B.splitWith f x; l1 = fromIntegral (length splits); l2 = B.length (B.filter f x) in + (l1 == l2 || l1 == l2 + 1) && sum (map B.length splits) + l2 == B.length x + , testProperty "splitAt" $ + \n x -> (B.unpack *** B.unpack) (B.splitAt n x) === splitAt (fromIntegral n) (B.unpack x) + + , testProperty "head" $ + \x -> not (B.null x) ==> B.head x === head (B.unpack x) + , testProperty "last" $ + \x -> not (B.null x) ==> B.last x === last (B.unpack x) + , testProperty "tail" $ + \x -> not (B.null x) ==> B.unpack (B.tail x) === tail (B.unpack x) + , testProperty "tail length" $ + \x -> not (B.null x) ==> B.length x === 1 + B.length (B.tail x) + , testProperty "init" $ + \x -> not (B.null x) ==> B.unpack (B.init x) === init (B.unpack x) + , testProperty "init length" $ + \x -> not (B.null x) ==> B.length x === 1 + B.length (B.init x) + + , testProperty "foldl" $ + \f (toElem -> c) x -> B.foldl ((toElem .) . f) c x === foldl ((toElem .) . f) c (B.unpack x) + , testProperty "foldl'" $ + \f (toElem -> c) x -> B.foldl' ((toElem .) . f) c x === foldl' ((toElem .) . f) c (B.unpack x) + , testProperty "foldr" $ + \f (toElem -> c) x -> B.foldr ((toElem .) . f) c x === foldr ((toElem .) . f) c (B.unpack x) + , testProperty "foldr'" $ + \f (toElem -> c) x -> B.foldr' ((toElem .) . f) c x === foldr' ((toElem .) . f) c (B.unpack x) + + , testProperty "foldl cons" $ + \x -> B.foldl (flip B.cons) B.empty x === B.reverse x + , testProperty "foldr cons" $ + \x -> B.foldr B.cons B.empty x === x + , testProperty "foldl special" $ + \x (toElem -> c) -> B.unpack (B.foldl (\acc t -> if t == c then acc else B.cons t acc) B.empty x) === + foldl (\acc t -> if t == c then acc else t : acc) [] (B.unpack x) + , testProperty "foldr special" $ + \x (toElem -> c) -> B.unpack (B.foldr (\t acc -> if t == c then acc else B.cons t acc) B.empty x) === + foldr (\t acc -> if t == c then acc else t : acc) [] (B.unpack x) + + , testProperty "foldl1" $ + \f x -> not (B.null x) ==> B.foldl1 ((toElem .) . f) x === foldl1 ((toElem .) . f) (B.unpack x) + , testProperty "foldl1'" $ + \f x -> not (B.null x) ==> B.foldl1' ((toElem .) . f) x === foldl1' ((toElem .) . f) (B.unpack x) + , testProperty "foldr1" $ + \f x -> not (B.null x) ==> B.foldr1 ((toElem .) . f) x === foldr1 ((toElem .) . f) (B.unpack x) + , testProperty "foldr1'" $ -- there is not Data.List.foldr1' + \f x -> not (B.null x) ==> B.foldr1' ((toElem .) . f) x === foldr1 ((toElem .) . f) (B.unpack x) + + , testProperty "foldl1 const" $ + \x -> not (B.null x) ==> B.foldl1 const x === B.head x + , testProperty "foldl1 flip const" $ + \x -> not (B.null x) ==> B.foldl1 (flip const) x === B.last x + , testProperty "foldr1 const" $ + \x -> not (B.null x) ==> B.foldr1 const x === B.head x + , testProperty "foldr1 flip const" $ + \x -> not (B.null x) ==> B.foldr1 (flip const) x === B.last x + , testProperty "foldl1 max" $ + \x -> not (B.null x) ==> B.foldl1 max x === B.foldl max minBound x + , testProperty "foldr1 max" $ + \x -> not (B.null x) ==> B.foldr1 max x === B.foldr max minBound x + + , testProperty "intercalate" $ + \x ys -> B.unpack (B.intercalate x ys) === intercalate (B.unpack x) (map B.unpack ys) + , testProperty "intercalate 'c' [x,y]" $ + \(toElem -> c) x y -> B.unpack (B.intercalate (B.singleton c) [x, y]) === intercalate [c] [B.unpack x, B.unpack y] + , testProperty "intercalate split" $ + \(toElem -> c) x -> B.intercalate (B.singleton c) (B.split c x) === x + + , testProperty "index" $ + \(NonNegative n) x -> fromIntegral n < B.length x ==> B.index x (fromIntegral n) === B.unpack x !! n + , testProperty "indexMaybe" $ + \(NonNegative n) x -> fromIntegral n < B.length x ==> B.indexMaybe x (fromIntegral n) === Just (B.unpack x !! n) + , testProperty "indexMaybe Nothing" $ + \n x -> (n :: Int) < 0 || fromIntegral n >= B.length x ==> B.indexMaybe x (fromIntegral n) === Nothing + , testProperty "!?" $ + \n x -> B.indexMaybe x (fromIntegral (n :: Int)) === x B.!? (fromIntegral n) + + , testProperty "unfoldrN" $ + \n f (toElem -> c) -> B.unpack (fst (B.unfoldrN n (fmap (first toElem) . f) c)) === + take (fromIntegral n) (unfoldr (fmap (first toElem) . f) c) + , testProperty "unfoldrN replicate" $ + \n (toElem -> c) -> fst (B.unfoldrN n (\t -> Just (t, t)) c) === B.replicate n c + , testProperty "unfoldr" $ + \n a (toElem -> c) -> B.unpack (B.unfoldr (\x -> if x <= 100 * n then Just (c, x + 1 :: Int) else Nothing) a) === + unfoldr (\x -> if x <= 100 * n then Just (c, x + 1) else Nothing) a + + --, testProperty "unfoldr" $ + -- \n f (toElem -> a) -> B.unpack (B.take (fromIntegral n) (B.unfoldr (fmap (first toElem) . f) a)) === + -- take n (unfoldr (fmap (first toElem) . f) a) + ] + +stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] +stripSuffix x y = fmap reverse (stripPrefix (reverse x) (reverse y)) + +split :: Eq a => a -> [a] -> [[a]] +split c = splitWith (== c) + +splitWith :: (a -> Bool) -> [a] -> [[a]] +splitWith _ [] = [] +splitWith f ys = go [] ys + where + go acc [] = [reverse acc] + go acc (x : xs) + | f x = reverse acc : go [] xs + | otherwise = go (x : acc) xs + diff --git a/tests/Properties/ByteString/Short.hs b/tests/Properties/ByteString/Short.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ByteString/Short.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE CPP #-} +#define WORD8 +#include "Common.hs" diff --git a/tests/Properties/ByteString/Short/Word16.hs b/tests/Properties/ByteString/Short/Word16.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ByteString/Short/Word16.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE CPP #-} +#define WORD16 +#include "../Common.hs"