diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,161 @@ # Revision history for byteslice +## 0.2.15.0 -- 2024-06-12 + +* Add functions for recovering length from `ByteArrayN` +* Add `Data.Bytes.Indexed` for functions on `ByteArrayN` + +## 0.2.14.0 -- 2024-02-26 + +* Add functions to `Data.Bytes.Text.AsciiExt`: `split(1|2|3|4)`, + `splitTetragram1`, `anyEq`, `takeWhileNotEq`, `dropWhileNotEq`, + `takeWhileEndNotEq`, dropWhileEndEq`. +* Increment upper bound on `primitive-unlifted` + +## 0.2.13.2 -- 2024-02-06 + +* Restore `Data.Bytes.Text.Utf8.toText`. + +## 0.2.13.1 -- 2024-02-01 + +* Update package metadata. + +## 0.2.13.0 -- 2024-01-12 + +* Add `replicate` and `replicateByte` to `Data.Bytes.Chunks`. + +## 0.2.12.0 -- 2023-12-14 + +* Add `Data.Bytes.Chunks.cons`. +* Add `Data.Bytes.fromLazyByteString`. +* Allow building with GHC 9.8. + +## 0.2.11.1 -- 2023-07-26 + +* Fix regression causing build failure in GHC 9.2. + +## 0.2.11.0 -- 2023-07-25 + +* Add `Data.Bytes.Encode.LittleEndian`. +* Add `splitTetragram1`. + +## 0.2.10.0 -- 2023-05-01 + +* Add `equals13`, `equals14`, `equals15`. +* Add `Show` instances for `BytesN` and `ByteArrayN`. +* Add `equalsCStringCaseInsensitive` for ascii text. + +## 0.2.9.0 -- 2022-12-08 + +* Add `toShortText`, `toShortTextU`, and `toText` to `Data.Byte.Text.Ascii`. +* Add `fromShortText` and `fromText` to `Data.Bytes.Text.Utf8`. + +## 0.2.8.0 -- 2022-11-21 + +* Add `Data.Bytes.replace` and `Data.Bytes.findIndices` +* Add `Data.Bytes.fromShortText` +* Add `Data.Bytes.fromPrimArray` +* Add `decodeDecWord` +* Add `concatArray` and `concatArrayU`. + +## 0.2.7.0 -- 2022-02-16 + +* Add support for GHC 9.2. +* Drop support for GHC 8.8 and earlier. +* Add `foldlM` and `foldrM` for mondic folds over byte sequences. + +## 0.2.6.0 -- 2021-09-15 + +* Add `BytesN` and `ByteArrayN`. +* Add `isInfixOf`. +* Add `hForLines_` and `hFoldLines`. +* Add `lift` and `unlift` for converting between `Bytes` and `Bytes#`. +* Move text-oriented functions from Data.Bytes to `Data.Bytes.Text.*`. + Provide aliases with older names that come with deprecation warning. + +## 0.2.5.2 -- 2021-02-23 + +* Correct compatibility shims. + +## 0.2.5.1 -- 2021-02-22 (deprecated) + +* Compatibility with GHC 9.0. + +## 0.2.5.0 -- 2021-01-22 + +* Add `Data.Bytes.Chunks.concatByteString`. +* Expose `pinnedToByteString` to end users. + +## 0.2.4.0 -- 2020-10-15 + +* Add `toByteString` and `fromByteString`. +* Add `fromShortByteString`. +* Add `equalsLatin(9|10|11|12)`. +* Add `toPinnedByteArray`, `toPinnedByteArrayClone`, and `concatPinnedU`. +* Add `toLowerAsciiByteArrayClone`. +* Add `intercalateByte2`. +* Add `splitEnd1`. + +## 0.2.3.0 -- 2020-04-30 + +* Add `fnv1a32` and `fnv1a64`, implementations of the 32-bit and + 64-bit variants of the FNV-1a hash algorithm, to both `Data.Bytes` + and `Data.Bytes.Chunks`. +* Add `Data.Bytes.Chunks.null`. +* Add `readFile` to both `Data.Bytes` and `Data.Bytes.Chunks`. +* Add `foldl'` to `Data.Bytes.Chunks`. +* Add `split` to `Data.Bytes.Chunks`. +* Add `splitStream` for splitting as a good stream-fusion producer. +* Add `hPut` and `writeFile` to `Data.Bytes.Chunks`. +* Add `fromCString#`. +* Add `Bytes#` newtype on GHC 8.10 and up. + +## 0.2.2.0 -- 2020-02-27 + +* Add `split4`. +* Add `equalsCString`. +* Add `stripCStringPrefix`. +* Add `equalsLatin8`. +* Add `emptyPinned`. +* Add `concatPinned` to `Data.Bytes.Chunks`. +* Add `any` and `all`. + +## 0.2.1.0 -- 2020-01-22 + +* Add `longestCommonPrefix`. +* Fix broken `Ord` instance of `Bytes`. + +## 0.2.0.0 -- 2020-01-20 + +* Change behavior of `split`. This function previously had a special case + for zero-length byte sequences to mirror the behavior `bytestring`'s + behavior. Now, `split` returns a singleton list with the empty byte + sequence in this case. +* Add `splitNonEmpty` so that users who need to take advantage of the + non-null guarantee `split` provides can do so. +* Add `splitU` and `splitInitU` for users who are going to split a + byte sequence without and consume the results more than once. +* Make the C code compile on platforms that do not have `rawmemchr`. +* Rename `splitOnce` to `split1`. +* Add `split2` and `split3`. +* Add `equalsLatin{1,2,3,4,5,6,7}` +* Add `ifoldl'`. +* Add `hGet` and `hPut`. +* Move `Data.Bytes.Chunks` from `small-bytearray-builder` to `byteslice`. +* Rename `Data.Bytes.Chunks.concat` to `concatU` (the U means unsliced), + and add a new `concat` that returns `Bytes`. +* Add `fromBytes`, `fromByteArray`, and `unsafeCopy` to `Data.Bytes.Chunks`. +* Add `hGetContents` to `Data.Bytes.Chunks`. +* Add `isBytePrefixOf` and `isByteSuffixOf`. +* Add `replicate` and `replicateU`. +* Add `Monoid` instance for `Bytes`. +* Add `singleton`, `doubleton`, `tripleton`, and their unsliced variants. +* Rename `copy` to `unsafeCopy`. +* Add `fromLatinString`. +* Change the behavior of `fromAsciiString` to replace out-of-bounds codepoints + with NUL. +* Add `unsnoc` and `uncons`. + ## 0.1.4.0 -- 2019-11-12 * Add `toLatinString`. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,25 @@ +# byteslice + +## Purpose + +Types for dealing with slices of 'ByteArray' and 'MutableByteArray'. +These are never supposed to introduce overhead. Rather, they exist +to clarify intent in type signatures. + + receive :: + Resource -- ^ Some scarce resource + -> MutableByteArray RealWorld -- ^ Buffer + -> Int -- ^ Offset + -> Int -- ^ Length + -> IO () + +With this library, we instead write + + receive :: + Resource -- ^ Some scarce resource + -> MutableBytes RealWorld -- ^ Buffer + -> IO () + +The combination of the worker-wrapper transformation and inlining means +that we can expect these two to end up generating the same code in most +situations. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,49 @@ +import Gauge.Main (bench, bgroup, defaultMain, whnf) + +import Data.Bytes.Types +import Data.List (permutations) + +import qualified Data.Bytes as Bytes +import qualified Data.Bytes.Text.Ascii as Ascii + +naiveMconcat :: [Bytes] -> Bytes +naiveMconcat = foldr mappend mempty + +main :: IO () +main = + defaultMain + [ bench "mconcat" $ whnf mconcat mconcatBytes + , bench "naiveMconcat" $ whnf naiveMconcat mconcatBytes + , bgroup + "replace" + [ bench "the-dog-and-the-shadow" (whnf replaceMeat theDogAndTheShadow) + ] + ] + +mconcatBytes :: [Bytes] +mconcatBytes = fmap Ascii.fromString $ permutations ['a' .. 'g'] + +replaceMeat :: Bytes -> Bytes +{-# NOINLINE replaceMeat #-} +replaceMeat x = Bytes.replace meat gruel x + +meat :: Bytes +meat = Ascii.fromString "meat" + +gruel :: Bytes +gruel = Ascii.fromString "gruel" + +theDogAndTheShadow :: Bytes +theDogAndTheShadow = + Ascii.fromString $ + concat + [ "It happened that a Dog had got a piece of meat and was " + , "carrying it home in his mouth to eat it in peace. " + , "Now on his way home he had to cross a plank lying across " + , "a running brook. As he crossed, he looked down and saw his " + , "own shadow reflected in the water beneath. Thinking it was " + , "another dog with another piece of meat, he made up his mind " + , "to have that also. So he made a snap at the shadow in the water, " + , "but as he opened his mouth the piece of meat fell out, dropped " + , "into the water and was never seen more." + ] diff --git a/byteslice.cabal b/byteslice.cabal --- a/byteslice.cabal +++ b/byteslice.cabal @@ -1,53 +1,126 @@ -cabal-version: 2.2 -name: byteslice -version: 0.1.4.0 -synopsis: Slicing managed and unmanaged memory +cabal-version: 2.4 +name: byteslice +version: 0.2.15.0 +synopsis: Slicing managed and unmanaged memory description: This library provides types that allow the user to talk about a slice of a ByteArray or a MutableByteArray. It also offers UnmanagedBytes, which is kind of like a slice into unmanaged memory. However, it is just an address and a length. -homepage: https://github.com/andrewthad/byteslice -bug-reports: https://github.com/andrewthad/byteslice/issues -license: BSD-3-Clause -license-file: LICENSE -author: Andrew Martin -maintainer: andrew.thaddeus@gmail.com -copyright: 2019 Andrew Martin -category: Data -extra-source-files: CHANGELOG.md +homepage: https://github.com/byteverse/byteslice +bug-reports: https://github.com/byteverse/byteslice/issues +license: BSD-3-Clause +license-file: LICENSE +author: Andrew Martin +maintainer: amartin@layer3com.com +copyright: 2020 Andrew Martin +category: Data +extra-doc-files: + CHANGELOG.md + README.md + +tested-with: GHC ==9.4.8 || ==9.6.3 || ==9.8.1 + +common build-settings + default-language: Haskell2010 + ghc-options: -Wall -Wunused-packages + +flag avoid-rawmemchr + default: True + description: Avoid using rawmemchr which is non-portable GNU libc only + library + import: build-settings exposed-modules: Data.Bytes + Data.Bytes.Chunks + Data.Bytes.Indexed + Data.Bytes.Encode.BigEndian + Data.Bytes.Encode.LittleEndian + Data.Bytes.Internal Data.Bytes.Mutable + Data.Bytes.Text.Ascii + Data.Bytes.Text.AsciiExt + Data.Bytes.Text.Latin1 + Data.Bytes.Text.Utf8 + Data.Bytes.Text.Windows1252 Data.Bytes.Types + other-modules: + Cstrlen Data.Bytes.Byte + Data.Bytes.Internal.Show + Data.Bytes.IO + Data.Bytes.Pure + Data.Bytes.Search + Reps + build-depends: - , base >=4.11.1 && <5 - , primitive >=0.7 && <0.8 - , primitive-addr >=0.1 && <0.2 - , run-st >=0.1 && <0.2 - hs-source-dirs: src - ghc-options: -Wall -O2 - default-language: Haskell2010 - include-dirs: include - includes: bs_custom.h + , base >=4.14 && <5 + , bytestring >=0.10.8 && <0.13 + , natural-arithmetic >=0.1.4 + , primitive >=0.7.4 && <0.10 + , primitive-addr >=0.1 && <0.2 + , primitive-unlifted >=0.1.2 && <2.3 + , run-st >=0.1.1 && <0.2 + , text >=1.2.5 + , text-short >=0.1.3 && <0.2 + , tuples >=0.1 && <0.2 + , vector >=0.12 && <0.14 + + hs-source-dirs: src + ghc-options: -O2 + + if impl(ghc >=9.2) + hs-source-dirs: src-new-reps + + else + hs-source-dirs: src-old-reps + + if impl(ghc >=9.0) + hs-source-dirs: src-ghc-cstrlen + + else + hs-source-dirs: src-no-ghc-cstrlen + + include-dirs: include + includes: bs_custom.h install-includes: bs_custom.h - c-sources: cbits/bs_custom.c + c-sources: cbits/bs_custom.c + if flag(avoid-rawmemchr) + cc-options: -DAVOID_RAWMEMCHR=1 + test-suite test - default-language: Haskell2010 - type: exitcode-stdio-1.0 + import: build-settings + type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: Main.hs - ghc-options: -Wall -O2 + main-is: Main.hs build-depends: - , base >=4.11.1 && <5 + , base >=4.11.1 && <5 , byteslice , bytestring , primitive - , tasty-hunit + , quickcheck-classes >=0.6.4 , tasty + , tasty-hunit , tasty-quickcheck + , text >=1.2 + , transformers + +benchmark bench + import: build-settings + type: exitcode-stdio-1.0 + build-depends: + , base + , byteslice + , gauge + + ghc-options: -O2 + hs-source-dirs: bench + main-is: Main.hs + +source-repository head + type: git + location: git://github.com/byteverse/byteslice.git diff --git a/cbits/bs_custom.c b/cbits/bs_custom.c --- a/cbits/bs_custom.c +++ b/cbits/bs_custom.c @@ -8,14 +8,25 @@ // to the sizes buffer. This uses rawmemchr, so the total number of // occurrences of the delimiter must be computed in advance. This // returns the total length of all pieces processed. -HsInt memchr_ba_many(unsigned char *p, HsInt off, HsInt *sizes, HsInt sizesLen, unsigned char w) { +// +// Portability: On Linux, this uses rawmemchr. On all other platforms, +// it uses memchr. On Linux, the length of the byte sequence is not +// used. On other platforms, this is repeatedly decremented to provide +// an appropriate third argument for memchr. +HsInt memchr_ba_many(unsigned char *p, HsInt off, HsInt len, HsInt *sizes, HsInt sizesLen, unsigned char w) { HsInt szIx, delta, total; unsigned char* pos; p = p + off; total = 0; for (szIx = 0; szIx < sizesLen; ++szIx) { - pos = (unsigned char*)(rawmemchr((void*)p,w)); - delta = pos - p; +#if defined(__linux__) && !AVOID_RAWMEMCHR + pos = (unsigned char*)(rawmemchr((void*)p,(int)w)); + delta = (HsInt)(pos - p); +#else + pos = (unsigned char*)(memchr((void*)p,(int)w,(size_t)len)); + delta = (HsInt)(pos - p); + len = len - (delta + 1); +#endif sizes[szIx] = delta; total = total + delta + 1; p = pos + 1; diff --git a/include/bs_custom.h b/include/bs_custom.h --- a/include/bs_custom.h +++ b/include/bs_custom.h @@ -3,5 +3,5 @@ #include #include "Rts.h" -HsInt memchr_ba_many(unsigned char *p, HsInt off, HsInt *sizes, HsInt sizesLen, unsigned char w); +HsInt memchr_ba_many(unsigned char *p, HsInt off, HsInt len, HsInt *sizes, HsInt sizesLen, unsigned char w); HsInt count_ba(unsigned char *p, HsInt off, HsInt len, unsigned char w); diff --git a/src-ghc-cstrlen/Cstrlen.hs b/src-ghc-cstrlen/Cstrlen.hs new file mode 100644 --- /dev/null +++ b/src-ghc-cstrlen/Cstrlen.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE MagicHash #-} + +module Cstrlen + ( cstringLength# + ) where + +import GHC.Exts (cstringLength#) diff --git a/src-new-reps/Reps.hs b/src-new-reps/Reps.hs new file mode 100644 --- /dev/null +++ b/src-new-reps/Reps.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedNewtypes #-} + +module Reps + ( Bytes# (..) + , word8ToWord# + ) where + +import GHC.Exts (ByteArray#, Int#, Levity (Unlifted), RuntimeRep (..), TYPE, word8ToWord#) + +newtype Bytes# :: TYPE ('TupleRep '[ 'BoxedRep 'Unlifted, 'IntRep, 'IntRep]) where + Bytes# :: (# ByteArray#, Int#, Int# #) -> Bytes# diff --git a/src-no-ghc-cstrlen/Cstrlen.hs b/src-no-ghc-cstrlen/Cstrlen.hs new file mode 100644 --- /dev/null +++ b/src-no-ghc-cstrlen/Cstrlen.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module Cstrlen + ( cstringLength# + ) where + +import GHC.Exts (Addr#, Int#) + +foreign import ccall unsafe "strlen" c_strlen :: Addr# -> Int# + +cstringLength# :: Addr# -> Int# +cstringLength# = c_strlen diff --git a/src-old-reps/Reps.hs b/src-old-reps/Reps.hs new file mode 100644 --- /dev/null +++ b/src-old-reps/Reps.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedNewtypes #-} + +module Reps + ( Bytes# (..) + , word8ToWord# + ) where + +import GHC.Exts (ByteArray#, Int#, RuntimeRep (..), TYPE, Word#) + +newtype Bytes# :: TYPE ('TupleRep '[ 'UnliftedRep, 'IntRep, 'IntRep]) where + Bytes# :: (# ByteArray#, Int#, Int# #) -> Bytes# + +-- In GHC 9.2, the lifted Word8 type started being backed by the +-- unlifted Word8# instead of by Word#. This is a compatibility hack. +word8ToWord# :: Word# -> Word# +{-# INLINE word8ToWord# #-} +word8ToWord# w = w diff --git a/src/Data/Bytes.hs b/src/Data/Bytes.hs --- a/src/Data/Bytes.hs +++ b/src/Data/Bytes.hs @@ -1,89 +1,287 @@ -{-# language BangPatterns #-} -{-# language MagicHash #-} -{-# language NamedFieldPuns #-} -{-# language TypeApplications #-} -{-# language UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnboxedTuples #-} +{- | If you are interested in sub-arrays of 'ByteArray's (e.g. writing a binary +search), it would be grossly inefficient to make a copy of the sub-array. On +the other hand, it'd be really annoying to track limit indices by hand. + +This module defines the 'Bytes' type which exposes a standard array interface +for a sub-arrays without copying and without manual index manipulation. -- +For mutable arrays, see 'Data.Bytes.Mutable'. +-} module Data.Bytes ( -- * Types Bytes + + -- * Constants + , Pure.empty + , Pure.emptyPinned + , Pure.emptyPinnedU + -- * Properties - , null - , length + , Pure.null + , Pure.length + + -- * Decompose + , uncons + , unsnoc + + -- * Predicates + , Pure.any + , Pure.all + + -- * Create + + -- ** Sliced + , singleton + , doubleton + , tripleton + , Pure.replicate + + -- ** Unsliced + , singletonU + , doubletonU + , tripletonU + , Pure.replicateU + -- * Filtering , takeWhile , dropWhile , takeWhileEnd , dropWhileEnd + + -- * Traversals + , Pure.map + , Pure.mapU + -- * Folds - , foldl - , foldl' - , foldr - , foldr' + , Pure.foldl + , Pure.foldl' + , Pure.foldr + , Pure.foldr' + + -- * Folds with Indices + , Pure.ifoldl' + + -- * Monadic Folds + , Pure.foldlM + , Pure.foldrM + -- * Common Folds , elem + -- * Splitting + + -- ** Unlimited , Byte.split + , Byte.splitU , Byte.splitInit - , splitFirst + , Byte.splitInitU + , Byte.splitNonEmpty + , Byte.splitStream + + -- ** Fixed from Beginning + , Byte.split1 + , Pure.splitTetragram1 + , Byte.split2 + , Byte.split3 + , Byte.split4 + + -- ** Fixed from End + , Byte.splitEnd1 + + -- * Combining + , intercalate + , intercalateByte2 + , concatArray + , concatArrayU + + -- * Searching + , replace + , findIndices + , Pure.findTetragramIndex + -- * Counting , Byte.count + -- * Prefix and Suffix + + -- ** Byte Sequence , isPrefixOf , isSuffixOf + , isInfixOf , stripPrefix , stripOptionalPrefix , stripSuffix , stripOptionalSuffix + , longestCommonPrefix + + -- ** C Strings + , stripCStringPrefix + + -- ** Single Byte + , isBytePrefixOf + , isByteSuffixOf + + -- * Equality + + -- ** Fixed Characters + , equalsLatin1 + , equalsLatin2 + , equalsLatin3 + , equalsLatin4 + , equalsLatin5 + , equalsLatin6 + , equalsLatin7 + , equalsLatin8 + , equalsLatin9 + , equalsLatin10 + , equalsLatin11 + , equalsLatin12 + + -- ** C Strings + , equalsCString + + -- * Hashing + , Pure.fnv1a32 + , Pure.fnv1a64 + -- * Unsafe Slicing - , unsafeTake - , unsafeDrop - , unsafeIndex + , Pure.unsafeTake + , Pure.unsafeDrop + , Pure.unsafeIndex + , Pure.unsafeHead + -- * Copying - , copy + , Pure.unsafeCopy + -- * Pointers - , pin - , contents + , Pure.pin + , Pure.contents , touch + -- * Conversion - , toByteArray - , toByteArrayClone + , Pure.toByteArray + , Pure.toByteArrayClone + , Pure.toPinnedByteArray + , Pure.toPinnedByteArrayClone , fromAsciiString - , fromByteArray + , fromLatinString + , Pure.fromByteArray + , Pure.fromPrimArray , toLatinString + , fromCString# + , Pure.toByteString + , Pure.pinnedToByteString + , Pure.fromByteString + , Pure.fromLazyByteString + , fromShortByteString + , fromShortText + , toShortByteString + , toShortByteStringClone + , toLowerAsciiByteArrayClone + + -- * I\/O with Handles + , BIO.hGet + , readFile + , BIO.hPut + + -- * Unlifted Types + , lift + , unlift + + -- * Length Indexed + , withLength + , withLengthU ) where -import Prelude hiding (length,takeWhile,dropWhile,null,foldl,foldr,elem) +import Prelude hiding (all, any, dropWhile, elem, foldl, foldr, length, map, null, readFile, replicate, takeWhile) -import Control.Monad.Primitive (PrimMonad,PrimState,primitive_,unsafeIOToPrim) +import Control.Monad.Primitive (PrimMonad, primitive_, unsafeIOToPrim) import Control.Monad.ST.Run (runByteArrayST) -import Control.Monad.ST (runST) -import Data.Bytes.Types (Bytes(Bytes,array,offset)) -import Data.Char (ord) -import Data.Primitive (ByteArray(ByteArray),MutableByteArray) -import GHC.Exts (Int(I#),Char(C#),word2Int#,chr#) -import GHC.Exts (Word#,Int#) -import GHC.Word (Word8(W8#)) -import Foreign.Ptr (Ptr,plusPtr) +import Cstrlen (cstringLength#) +import Data.ByteString.Short.Internal (ShortByteString (SBS)) +import Data.Bytes.Pure (fromByteArray, length, toShortByteString, unsafeDrop, unsafeIndex) +import Data.Bytes.Search (findIndices, isInfixOf, replace) +import Data.Bytes.Types (ByteArrayN (ByteArrayN), Bytes (Bytes, array, offset), BytesN (BytesN)) +import Data.Primitive (Array, ByteArray (ByteArray)) +import Data.Text.Short (ShortText) +import Foreign.C.String (CString) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import GHC.Exts (Addr#, Int (I#), Int#, Ptr (Ptr), Word#) +import GHC.Word (Word8 (W8#)) +import Reps (Bytes# (..), word8ToWord#) -import qualified Data.Primitive as PM +import qualified Arithmetic.Nat as Nat +import qualified Arithmetic.Types as Arithmetic import qualified Data.Bytes.Byte as Byte +import qualified Data.Bytes.Chunks as Chunks +import qualified Data.Bytes.IO as BIO +import qualified Data.Bytes.Pure as Pure +import qualified Data.Bytes.Text.Ascii as Ascii +import qualified Data.Bytes.Text.AsciiExt as AsciiExt +import qualified Data.Bytes.Text.Latin1 as Latin1 +import qualified Data.Bytes.Types as Types +import qualified Data.Foldable as F +import qualified Data.List as List +import qualified Data.Primitive as PM +import qualified Data.Primitive.Ptr as PM +import qualified Data.Text.Short as TS import qualified GHC.Exts as Exts +import qualified GHC.TypeNats as GHC --- | Is the byte sequence empty? -null :: Bytes -> Bool -null (Bytes _ _ len) = len == 0 +{- | Extract the head and tail of the 'Bytes', returning 'Nothing' if +it is empty. +-} +uncons :: Bytes -> Maybe (Word8, Bytes) +{-# INLINE uncons #-} +uncons b = case length b of + 0 -> Nothing + _ -> Just (unsafeIndex b 0, unsafeDrop 1 b) --- | The length of a slice of bytes. -length :: Bytes -> Int -length (Bytes _ _ len) = len +{- | Extract the @init@ and @last@ of the 'Bytes', returning 'Nothing' if +it is empty. +-} +unsnoc :: Bytes -> Maybe (Bytes, Word8) +{-# INLINE unsnoc #-} +unsnoc b@(Bytes arr off len) = case len of + 0 -> Nothing + _ -> + let !len' = len - 1 + in Just (Bytes arr off len', unsafeIndex b len') +{- | Does the byte sequence begin with the given byte? False if the +byte sequence is empty. +-} +isBytePrefixOf :: Word8 -> Bytes -> Bool +{-# INLINE isBytePrefixOf #-} +isBytePrefixOf w b = case length b of + 0 -> False + _ -> unsafeIndex b 0 == w + +{- | Does the byte sequence end with the given byte? False if the +byte sequence is empty. +-} +isByteSuffixOf :: Word8 -> Bytes -> Bool +isByteSuffixOf w b = case len of + 0 -> False + _ -> unsafeIndex b (len - 1) == w + where + len = length b + -- | Is the first argument a prefix of the second argument? isPrefixOf :: Bytes -> Bytes -> Bool isPrefixOf (Bytes a aOff aLen) (Bytes b bOff bLen) = -- For prefix and suffix testing, we do not use -- the sameByteArray optimization that we use in - -- the Eq instance. Prefix and suffix testing seldom + -- the Eq instance. Prefix and suffix testing seldom -- compares a byte array with the same in-memory -- byte array. if aLen <= bLen @@ -97,239 +295,453 @@ then compareByteArrays a aOff b (bOff + bLen - aLen) aLen == EQ else False --- | /O(n)/ Return the suffix of the second string if its prefix --- matches the entire first string. +-- | Find the longest string which is a prefix of both arguments. +longestCommonPrefix :: Bytes -> Bytes -> Bytes +longestCommonPrefix a b = loop 0 + where + loop :: Int -> Bytes + loop !into + | into < maxLen + && unsafeIndex a into == unsafeIndex b into = + loop (into + 1) + | otherwise = Pure.unsafeTake into a + maxLen = min (length a) (length b) + +-- | Create a byte sequence with one byte. +singleton :: Word8 -> Bytes +{-# INLINE singleton #-} +singleton !a = Bytes (singletonU a) 0 1 + +-- | Create a byte sequence with two bytes. +doubleton :: Word8 -> Word8 -> Bytes +{-# INLINE doubleton #-} +doubleton !a !b = Bytes (doubletonU a b) 0 2 + +-- | Create a byte sequence with three bytes. +tripleton :: Word8 -> Word8 -> Word8 -> Bytes +{-# INLINE tripleton #-} +tripleton !a !b !c = Bytes (tripletonU a b c) 0 3 + +-- | Create an unsliced byte sequence with one byte. +singletonU :: Word8 -> ByteArray +{-# INLINE singletonU #-} +singletonU !a = runByteArrayST do + arr <- PM.newByteArray 1 + PM.writeByteArray arr 0 a + PM.unsafeFreezeByteArray arr + +-- | Create an unsliced byte sequence with two bytes. +doubletonU :: Word8 -> Word8 -> ByteArray +{-# INLINE doubletonU #-} +doubletonU !a !b = runByteArrayST do + arr <- PM.newByteArray 2 + PM.writeByteArray arr 0 a + PM.writeByteArray arr 1 b + PM.unsafeFreezeByteArray arr + +-- | Create an unsliced byte sequence with three bytes. +tripletonU :: Word8 -> Word8 -> Word8 -> ByteArray +{-# INLINE tripletonU #-} +tripletonU !a !b !c = runByteArrayST do + arr <- PM.newByteArray 3 + PM.writeByteArray arr 0 a + PM.writeByteArray arr 1 b + PM.writeByteArray arr 2 c + PM.unsafeFreezeByteArray arr + +{- | /O(n)/ Return the suffix of the second string if its prefix +matches the entire first string. +-} stripPrefix :: Bytes -> Bytes -> Maybe Bytes -stripPrefix !pre !str = if pre `isPrefixOf` str - then Just (Bytes (array str) (offset str + length pre) (length str - length pre)) - else Nothing +stripPrefix !pre !str = + if pre `isPrefixOf` str + then Just (Bytes (array str) (offset str + length pre) (length str - length pre)) + else Nothing --- | /O(n)/ Return the suffix of the second string if its prefix --- matches the entire first string. Otherwise, return the second --- string unchanged. +{- | /O(n)/ Return the suffix of the second string if its prefix +matches the entire first string. Otherwise, return the second +string unchanged. +-} stripOptionalPrefix :: Bytes -> Bytes -> Bytes -stripOptionalPrefix !pre !str = if pre `isPrefixOf` str - then Bytes (array str) (offset str + length pre) (length str - length pre) - else str +stripOptionalPrefix !pre !str = + if pre `isPrefixOf` str + then Bytes (array str) (offset str + length pre) (length str - length pre) + else str --- | /O(n)/ Return the prefix of the second string if its suffix --- matches the entire first string. +{- | /O(n)/ Return the prefix of the second string if its suffix +matches the entire first string. +-} stripSuffix :: Bytes -> Bytes -> Maybe Bytes -stripSuffix !suf !str = if suf `isSuffixOf` str - then Just (Bytes (array str) (offset str) (length str - length suf)) - else Nothing +stripSuffix !suf !str = + if suf `isSuffixOf` str + then Just (Bytes (array str) (offset str) (length str - length suf)) + else Nothing --- | /O(n)/ Return the prefix of the second string if its suffix --- matches the entire first string. Otherwise, return the second --- string unchanged. +{- | /O(n)/ Return the prefix of the second string if its suffix +matches the entire first string. Otherwise, return the second +string unchanged. +-} stripOptionalSuffix :: Bytes -> Bytes -> Bytes -stripOptionalSuffix !suf !str = if suf `isSuffixOf` str - then Bytes (array str) (offset str) (length str - length suf) - else str - --- | Split a byte sequence on the first occurrence of the target --- byte. The target is removed from the result. For example: --- --- >>> splitOnce 0xA [0x1,0x2,0xA,0xB] --- Just ([0x1,0x2],[0xB]) -splitFirst :: Word8 -> Bytes -> Maybe (Bytes,Bytes) -{-# inline splitFirst #-} -splitFirst w b@(Bytes arr off len) = case elemIndexLoop# w b of - (-1#) -> Nothing - i# -> let i = I# i# in - Just (Bytes arr off (i - off), Bytes arr (i + 1) (len - (1 + i - off))) - --- This returns the offset into the byte array. This is not an index --- that will mean anything to the end user, so it cannot be returned --- to them. -elemIndexLoop# :: Word8 -> Bytes -> Int# -elemIndexLoop# !w (Bytes arr off@(I# off# ) len) = case len of - 0 -> (-1#) - _ -> if PM.indexByteArray arr off == w - then off# - else elemIndexLoop# w (Bytes arr (off + 1) (len - 1)) +stripOptionalSuffix !suf !str = + if suf `isSuffixOf` str + then Bytes (array str) (offset str) (length str - length suf) + else str +-- | Is the byte a member of the byte sequence? elem :: Word8 -> Bytes -> Bool -elem (W8# w) b = case elemLoop 0# w b of +elem (W8# w) b = case elemLoop 0# (word8ToWord# w) b of 1# -> True _ -> False elemLoop :: Int# -> Word# -> Bytes -> Int# -elemLoop !r !w (Bytes arr@(ByteArray arr# ) off@(I# off# ) len) = case len of +elemLoop !r !w (Bytes arr@(ByteArray arr#) off@(I# off#) len) = case len of 0 -> r - _ -> elemLoop (Exts.orI# r (Exts.eqWord# w (Exts.indexWord8Array# arr# off# ) )) w (Bytes arr (off + 1) (len - 1)) + _ -> elemLoop (Exts.orI# r (Exts.eqWord# w (word8ToWord# (Exts.indexWord8Array# arr# off#)))) w (Bytes arr (off + 1) (len - 1)) -- | Take bytes while the predicate is true. takeWhile :: (Word8 -> Bool) -> Bytes -> Bytes -{-# inline takeWhile #-} -takeWhile k b = unsafeTake (countWhile k b) b +{-# INLINE takeWhile #-} +takeWhile k b = Pure.unsafeTake (Pure.countWhile k b) b -- | Drop bytes while the predicate is true. dropWhile :: (Word8 -> Bool) -> Bytes -> Bytes -{-# inline dropWhile #-} -dropWhile k b = unsafeDrop (countWhile k b) b - --- | Index into the byte sequence at the given position. This index --- must be less than the length. -unsafeIndex :: Bytes -> Int -> Word8 -unsafeIndex (Bytes arr off _) ix = PM.indexByteArray arr (off + ix) +{-# INLINE dropWhile #-} +dropWhile k b = Pure.unsafeDrop (Pure.countWhile k b) b --- | /O(n)/ 'dropWhileEnd' @p@ @b@ returns the prefix remaining after --- dropping characters that satisfy the predicate @p@ from the end of --- @t@. +{- | /O(n)/ 'dropWhileEnd' @p@ @b@ returns the prefix remaining after +dropping characters that satisfy the predicate @p@ from the end of +@t@. +-} dropWhileEnd :: (Word8 -> Bool) -> Bytes -> Bytes -{-# inline dropWhileEnd #-} -dropWhileEnd k !b = unsafeTake (length b - countWhileEnd k b) b +{-# INLINE dropWhileEnd #-} +dropWhileEnd k !b = Pure.unsafeTake (length b - Pure.countWhileEnd k b) b --- | /O(n)/ 'takeWhileEnd' @p@ @b@ returns the longest suffix of --- elements that satisfy predicate @p@. +{- | /O(n)/ 'takeWhileEnd' @p@ @b@ returns the longest suffix of +elements that satisfy predicate @p@. +-} takeWhileEnd :: (Word8 -> Bool) -> Bytes -> Bytes -{-# inline takeWhileEnd #-} +{-# INLINE takeWhileEnd #-} takeWhileEnd k !b = - let n = countWhileEnd k b + let n = Pure.countWhileEnd k b in Bytes (array b) (offset b + length b - n) n --- | Take the first @n@ bytes from the argument. Precondition: @n ≤ len@ -unsafeTake :: Int -> Bytes -> Bytes -{-# inline unsafeTake #-} -unsafeTake n (Bytes arr off _) = - Bytes arr off n +{- | Convert a 'String' consisting of only characters in the ASCII block +to a byte sequence. Any character with a codepoint above @U+007F@ is +replaced by @U+0000@. +-} +fromAsciiString :: String -> Bytes +{-# DEPRECATED fromAsciiString "use Data.Bytes.Text.Ascii.fromString instead" #-} +{-# INLINE fromAsciiString #-} +fromAsciiString = Ascii.fromString --- | Drop the first @n@ bytes from the argument. Precondition: @n ≤ len@ -unsafeDrop :: Int -> Bytes -> Bytes -{-# inline unsafeDrop #-} -unsafeDrop n (Bytes arr off len) = - Bytes arr (off + n) (len - n) +{- | Convert a 'String' consisting of only characters representable +by ISO-8859-1. These are encoded with ISO-8859-1. Any character +with a codepoint above @U+00FF@ is replaced by an unspecified byte. +-} +fromLatinString :: String -> Bytes +{-# DEPRECATED fromLatinString "use Data.Bytes.Text.Latin1.fromString instead" #-} +{-# INLINE fromLatinString #-} +fromLatinString = Latin1.fromString --- Internal. The returns the number of bytes that match the --- predicate until the first non-match occurs. If all bytes --- match the predicate, this will return the length originally --- provided. -countWhile :: (Word8 -> Bool) -> Bytes -> Int -{-# inline countWhile #-} -countWhile k (Bytes arr off0 len0) = go off0 len0 0 where - go !off !len !n = if len > 0 - then if k (PM.indexByteArray arr off) - then go (off + 1) (len - 1) (n + 1) - else n - else n +-- | Interpret a byte sequence as text encoded by ISO-8859-1. +toLatinString :: Bytes -> String +{-# DEPRECATED toLatinString "use Data.Bytes.Text.Latin1.toString instead" #-} +{-# INLINE toLatinString #-} +toLatinString = Latin1.toString --- Internal. Variant of countWhile that starts from the end --- of the string instead of the beginning. -countWhileEnd :: (Word8 -> Bool) -> Bytes -> Int -{-# inline countWhileEnd #-} -countWhileEnd k (Bytes arr off0 len0) = go (off0 + len0 - 1) (len0 - 1) 0 where - go !off !len !n = if len >= 0 - then if k (PM.indexByteArray arr off) - then go (off - 1) (len - 1) (n + 1) - else n - else n +-- | Copy a primitive string literal into managed memory. +fromCString# :: Addr# -> Bytes +fromCString# a = + Bytes + ( runByteArrayST $ do + dst@(PM.MutableByteArray dst#) <- PM.newByteArray len + PM.copyPtrToMutablePrimArray + (PM.MutablePrimArray dst#) + 0 + (Ptr a :: Ptr Word8) + len + PM.unsafeFreezeByteArray dst + ) + 0 + len + where + len = I# (cstringLength# a) --- | Left fold over bytes, non-strict in the accumulator. -foldl :: (a -> Word8 -> a) -> a -> Bytes -> a -{-# inline foldl #-} -foldl f a0 (Bytes arr off0 len0) = - go (off0 + len0 - 1) (len0 - 1) - where - go !off !ix = case ix of - (-1) -> a0 - _ -> f (go (off - 1) (ix - 1)) (PM.indexByteArray arr off) +compareByteArrays :: ByteArray -> Int -> ByteArray -> Int -> Int -> Ordering +{-# INLINE compareByteArrays #-} +compareByteArrays (ByteArray ba1#) (I# off1#) (ByteArray ba2#) (I# off2#) (I# n#) = + compare (I# (Exts.compareByteArrays# ba1# off1# ba2# off2# n#)) 0 --- | Right fold over bytes, non-strict in the accumulator. -foldr :: (Word8 -> a -> a) -> a -> Bytes -> a -{-# inline foldr #-} -foldr f a0 (Bytes arr off0 len0) = go off0 len0 where - go !off !len = case len of - 0 -> a0 - _ -> f (PM.indexByteArray arr off) (go (off + 1) (len - 1)) +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a singleton whose element matches the character? +-} +equalsLatin1 :: Char -> Bytes -> Bool +{-# DEPRECATED equalsLatin1 "use Data.Bytes.Text.Latin1.equals1 instead" #-} +{-# INLINE equalsLatin1 #-} +equalsLatin1 = Latin1.equals1 --- | Left fold over bytes, strict in the accumulator. -foldl' :: (a -> Word8 -> a) -> a -> Bytes -> a -{-# inline foldl' #-} -foldl' f a0 (Bytes arr off0 len0) = go a0 off0 len0 where - go !a !off !len = case len of - 0 -> a - _ -> go (f a (PM.indexByteArray arr off)) (off + 1) (len - 1) +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a doubleton whose elements match the characters? +-} +equalsLatin2 :: Char -> Char -> Bytes -> Bool +{-# DEPRECATED equalsLatin2 "use Data.Bytes.Text.Latin1.equals2 instead" #-} +{-# INLINE equalsLatin2 #-} +equalsLatin2 = Latin1.equals2 --- | Right fold over bytes, strict in the accumulator. -foldr' :: (Word8 -> a -> a) -> a -> Bytes -> a -{-# inline foldr' #-} -foldr' f a0 (Bytes arr off0 len0) = - go a0 (off0 + len0 - 1) (len0 - 1) - where - go !a !off !ix = case ix of - (-1) -> a - _ -> go (f (PM.indexByteArray arr off) a) (off - 1) (ix - 1) +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a tripleton whose elements match the characters? +-} +equalsLatin3 :: Char -> Char -> Char -> Bytes -> Bool +{-# DEPRECATED equalsLatin3 "use Data.Bytes.Text.Latin1.equals3 instead" #-} +{-# INLINE equalsLatin3 #-} +equalsLatin3 = Latin1.equals3 --- | Convert the sliced 'Bytes' to an unsliced 'ByteArray'. This --- reuses the array backing the sliced 'Bytes' if the slicing metadata --- implies that all of the bytes are used. Otherwise, it makes a copy. -toByteArray :: Bytes -> ByteArray -toByteArray b@(Bytes arr off len) - | off /= 0 = toByteArrayClone b - | PM.sizeofByteArray arr /= len = toByteArrayClone b - | otherwise = arr +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a quadrupleton whose elements match the characters? +-} +equalsLatin4 :: Char -> Char -> Char -> Char -> Bytes -> Bool +{-# DEPRECATED equalsLatin4 "use Data.Bytes.Text.Latin1.equals4 instead" #-} +{-# INLINE equalsLatin4 #-} +equalsLatin4 = Latin1.equals4 --- | Variant of 'toByteArray' that unconditionally makes a copy of --- the array backing the sliced 'Bytes' even if the original array --- could be reused. Prefer 'toByteArray'. -toByteArrayClone :: Bytes -> ByteArray -toByteArrayClone (Bytes arr off len) = runByteArrayST $ do - m <- PM.newByteArray len - PM.copyByteArray m 0 arr off len - PM.unsafeFreezeByteArray m +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a quintupleton whose elements match the characters? +-} +equalsLatin5 :: Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +{-# DEPRECATED equalsLatin5 "use Data.Bytes.Text.Latin1.equals5 instead" #-} +{-# INLINE equalsLatin5 #-} +equalsLatin5 = Latin1.equals5 --- | Convert a 'String' consisting of only characters --- in the ASCII block. -fromAsciiString :: String -> Bytes -fromAsciiString = fromByteArray . Exts.fromList . map (fromIntegral @Int @Word8 . ord) +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a sextupleton whose elements match the characters? +-} +equalsLatin6 :: Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +{-# DEPRECATED equalsLatin6 "use Data.Bytes.Text.Latin1.equals6 instead" #-} +{-# INLINE equalsLatin6 #-} +equalsLatin6 = Latin1.equals6 --- | Interpret a byte sequence as text encoded by ISO-8859-1. -toLatinString :: Bytes -> String -toLatinString = foldr (\(W8# w) xs -> C# (chr# (word2Int# w)) : xs) [] +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a septupleton whose elements match the characters? +-} +equalsLatin7 :: Char -> Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +{-# DEPRECATED equalsLatin7 "use Data.Bytes.Text.Latin1.equals7 instead" #-} +{-# INLINE equalsLatin7 #-} +equalsLatin7 = Latin1.equals7 --- | Create a slice of 'Bytes' that spans the entire argument array. -fromByteArray :: ByteArray -> Bytes -fromByteArray b = Bytes b 0 (PM.sizeofByteArray b) +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +an octupleton whose elements match the characters? +-} +equalsLatin8 :: Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +{-# DEPRECATED equalsLatin8 "use Data.Bytes.Text.Latin1.equals8 instead" #-} +{-# INLINE equalsLatin8 #-} +equalsLatin8 = Latin1.equals8 -compareByteArrays :: ByteArray -> Int -> ByteArray -> Int -> Int -> Ordering -{-# INLINE compareByteArrays #-} -compareByteArrays (ByteArray ba1#) (I# off1#) (ByteArray ba2#) (I# off2#) (I# n#) = - compare (I# (Exts.compareByteArrays# ba1# off1# ba2# off2# n#)) 0 +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a 9-tuple whose elements match the characters? +-} +equalsLatin9 :: Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +{-# DEPRECATED equalsLatin9 "use Data.Bytes.Text.Latin1.equals9 instead" #-} +{-# INLINE equalsLatin9 #-} +equalsLatin9 = Latin1.equals9 --- | Copy the byte sequence into a mutable buffer. The buffer must have --- enough space to accomodate the byte sequence, but this this is not --- checked. -copy :: PrimMonad m - => MutableByteArray (PrimState m) -- ^ Destination - -> Int -- ^ Destination Offset - -> Bytes -- ^ Source - -> m () -{-# inline copy #-} -copy dst dstIx (Bytes src srcIx len) = - PM.copyByteArray dst dstIx src srcIx len +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a 10-tuple whose elements match the characters? +-} +equalsLatin10 :: Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +{-# DEPRECATED equalsLatin10 "use Data.Bytes.Text.Latin1.equals10 instead" #-} +{-# INLINE equalsLatin10 #-} +equalsLatin10 = Latin1.equals10 --- | Yields a pinned byte sequence whose contents are identical to those --- of the original byte sequence. If the @ByteArray@ backing the argument --- was already pinned, this simply aliases the argument and does not perform --- any copying. -pin :: Bytes -> Bytes -pin b@(Bytes arr _ len) = case PM.isByteArrayPinned arr of - True -> b - False -> runST $ do - dst <- PM.newPinnedByteArray len - copy dst 0 b - r <- PM.unsafeFreezeByteArray dst - pure (Bytes r 0 len) +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a 11-tuple whose elements match the characters? +-} +equalsLatin11 :: Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +{-# DEPRECATED equalsLatin11 "use Data.Bytes.Text.Latin1.equals11 instead" #-} +{-# INLINE equalsLatin11 #-} +equalsLatin11 = Latin1.equals11 --- | Yields a pointer to the beginning of the byte sequence. It is only safe --- to call this on a 'Bytes' backed by a pinned @ByteArray@. -contents :: Bytes -> Ptr Word8 -contents (Bytes arr off _) = plusPtr (PM.byteArrayContents arr) off +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a 12-tuple whose elements match the characters? +-} +equalsLatin12 :: Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +{-# DEPRECATED equalsLatin12 "use Data.Bytes.Text.Latin1.equals12 instead" #-} +{-# INLINE equalsLatin12 #-} +equalsLatin12 = Latin1.equals12 --- | Touch the byte array backing the byte sequence. This sometimes needed --- after calling 'contents' so that the @ByteArray@ does not get garbage --- collected. -touch :: PrimMonad m => Bytes -> m () -touch (Bytes (ByteArray arr) _ _) = unsafeIOToPrim - (primitive_ (\s -> Exts.touch# arr s)) +{- | Is the byte sequence equal to the @NUL@-terminated C String? +The C string must be a constant. +-} +equalsCString :: CString -> Bytes -> Bool +{-# INLINE equalsCString #-} +equalsCString !ptr0 (Bytes arr off0 len0) = go (castPtr ptr0 :: Ptr Word8) off0 len0 + where + go !ptr !off !len = case len of + 0 -> PM.indexOffPtr ptr 0 == (0 :: Word8) + _ -> case PM.indexOffPtr ptr 0 of + 0 -> False + c -> c == PM.indexByteArray arr off && go (plusPtr ptr 1) (off + 1) (len - 1) + +{- | /O(n)/ Variant of 'stripPrefix' that takes a @NUL@-terminated C String +as the prefix to test for. +-} +stripCStringPrefix :: CString -> Bytes -> Maybe Bytes +{-# INLINE stripCStringPrefix #-} +stripCStringPrefix !ptr0 (Bytes arr off0 len0) = go (castPtr ptr0 :: Ptr Word8) off0 len0 + where + go !ptr !off !len = case PM.indexOffPtr ptr 0 of + 0 -> Just (Bytes arr off len) + c -> case len of + 0 -> Nothing + _ -> case c == PM.indexByteArray arr off of + True -> go (plusPtr ptr 1) (off + 1) (len - 1) + False -> Nothing + +{- | Touch the byte array backing the byte sequence. This sometimes needed +after calling 'Pure.contents' so that the @ByteArray@ does not get garbage +collected. +-} +touch :: (PrimMonad m) => Bytes -> m () +touch (Bytes (ByteArray arr) _ _) = + unsafeIOToPrim + (primitive_ (\s -> Exts.touch# arr s)) + +-- | Read an entire file strictly into a 'Bytes'. +readFile :: FilePath -> IO Bytes +readFile f = Chunks.concat <$> Chunks.readFile f + +{- | /O(n)/ The intercalate function takes a separator 'Bytes' and a list of +'Bytes' and concatenates the list elements by interspersing the separator +between each element. +-} +intercalate :: + -- | Separator (interspersed into the list) + Bytes -> + -- | List + [Bytes] -> + Bytes +intercalate !_ [] = mempty +intercalate !_ [x] = x +intercalate (Bytes sarr soff slen) (Bytes arr0 off0 len0 : bs) = Bytes r 0 fullLen + where + !fullLen = List.foldl' (\acc (Bytes _ _ len) -> acc + len + slen) 0 bs + len0 + r = runByteArrayST $ do + marr <- PM.newByteArray fullLen + PM.copyByteArray marr 0 arr0 off0 len0 + !_ <- + F.foldlM + ( \ !currLen (Bytes arr off len) -> do + PM.copyByteArray marr currLen sarr soff slen + PM.copyByteArray marr (currLen + slen) arr off len + pure (currLen + len + slen) + ) + len0 + bs + PM.unsafeFreezeByteArray marr + +{- | Specialization of 'intercalate' where the separator is a single byte and +there are exactly two byte sequences that are being concatenated. +-} +intercalateByte2 :: + -- | Separator + Word8 -> + -- | First byte sequence + Bytes -> + -- | Second byte sequence + Bytes -> + Bytes +intercalateByte2 !sep !a !b = + Bytes + { Types.array = runByteArrayST $ do + dst <- PM.newByteArray len + Pure.unsafeCopy dst 0 a + PM.writeByteArray dst (length a) sep + Pure.unsafeCopy dst (length a + 1) b + PM.unsafeFreezeByteArray dst + , Types.length = len + , Types.offset = 0 + } + where + len = length a + length b + 1 + +{- | Variant of 'toShortByteString' that unconditionally makes a copy of +the array backing the sliced 'Bytes' even if the original array +could be reused. Prefer 'toShortByteString'. +-} +toShortByteStringClone :: Bytes -> ShortByteString +{-# INLINE toShortByteStringClone #-} +toShortByteStringClone !b = case Pure.toByteArrayClone b of + PM.ByteArray x -> SBS x + +-- | /O(1)/ Create 'Bytes' from a 'ShortByteString'. +fromShortByteString :: ShortByteString -> Bytes +{-# INLINE fromShortByteString #-} +fromShortByteString (SBS x) = fromByteArray (ByteArray x) + +{- | /O(1)/ Create 'Bytes' from a 'ShortText'. This encodes the text as UTF-8. +It is a no-op. +-} +fromShortText :: ShortText -> Bytes +{-# INLINE fromShortText #-} +fromShortText t = case TS.toShortByteString t of + SBS x -> fromByteArray (ByteArray x) + +{- | /O(n)/ Interpreting the bytes an ASCII-encoded characters, convert +the string to lowercase. This adds @0x20@ to bytes in the range +@[0x41,0x5A]@ and leaves all other bytes alone. Unconditionally +copies the bytes. +-} +toLowerAsciiByteArrayClone :: Bytes -> ByteArray +{-# DEPRECATED toLowerAsciiByteArrayClone "use Data.Bytes/Text/AsciiExt.toLowerU" #-} +{-# INLINE toLowerAsciiByteArrayClone #-} +toLowerAsciiByteArrayClone = AsciiExt.toLowerU + +lift :: Bytes# -> Bytes +{-# INLINE lift #-} +lift (Bytes# (# arr, off, len #)) = Bytes (ByteArray arr) (I# off) (I# len) + +unlift :: Bytes -> Bytes# +{-# INLINE unlift #-} +unlift (Bytes (ByteArray arr) (I# off) (I# len)) = + Bytes# (# arr, off, len #) + +concatArrayU :: Array Bytes -> ByteArray +{-# NOINLINE concatArrayU #-} +concatArrayU !xs = runByteArrayST $ do + let !arrLen = PM.sizeofArray xs + let !totalByteLen = F.foldl' (\acc b -> length b + acc) 0 xs + dst <- PM.newByteArray totalByteLen + let go !ix !dstOff = + if ix < arrLen + then do + x <- PM.indexArrayM xs ix + Pure.unsafeCopy dst dstOff x + go (ix + 1) (dstOff + length x) + else PM.unsafeFreezeByteArray dst + go 0 0 + +concatArray :: Array Bytes -> Bytes +{-# INLINE concatArray #-} +concatArray !xs = Pure.fromByteArray (concatArrayU xs) + +{- | Convert 'Bytes' to 'BytesN', exposing the length in a type-safe +way in the callback. +-} +withLength :: + Bytes -> + (forall (n :: GHC.Nat). Arithmetic.Nat n -> BytesN n -> a) -> + a +{-# INLINE withLength #-} +withLength Bytes {array, offset, length = len} f = + Nat.with + len + (\n -> f n BytesN {array, offset}) + +withLengthU :: + ByteArray -> + (forall (n :: GHC.Nat). Arithmetic.Nat n -> ByteArrayN n -> a) -> + a +{-# INLINE withLengthU #-} +withLengthU !arr f = + Nat.with + (PM.sizeofByteArray arr) + (\n -> f n (ByteArrayN arr)) diff --git a/src/Data/Bytes/Byte.hs b/src/Data/Bytes/Byte.hs --- a/src/Data/Bytes/Byte.hs +++ b/src/Data/Bytes/Byte.hs @@ -1,117 +1,347 @@ -{-# language BangPatterns #-} -{-# language BlockArguments #-} -{-# language MagicHash #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language TypeApplications #-} -{-# language UnliftedFFITypes #-} -{-# language UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnliftedFFITypes #-} -- This internal module has functions for splitting strings -- on a particular byte and for counting occurences of that -- byte. module Data.Bytes.Byte - ( count + ( -- Re-exported by Data.Bytes + count , split + , splitU + , splitNonEmpty + , splitStream , splitInit + , splitInitU + , split1 + , split2 + , split3 + , split4 + , splitEnd1 + -- Used by other internal modules + , elemIndexLoop# ) where import Prelude hiding (length) -import GHC.IO (unsafeIOToST) -import Data.Primitive (PrimArray(..),MutablePrimArray(..),ByteArray(..)) -import Data.Word (Word8) -import GHC.Exts (Int(I#),ByteArray#,MutableByteArray#,Int#,Word#) -import GHC.Word (Word8(W8#)) -import Data.Bytes.Types (Bytes(..)) +import Control.Monad.ST (runST) import Control.Monad.ST.Run (runPrimArrayST) +import Data.Bytes.Types (Bytes (..)) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Primitive (ByteArray (..), MutablePrimArray (..), PrimArray (..)) +import Data.Primitive.Unlifted.Array (UnliftedArray) +import Data.Tuple.Types (IntPair (IntPair)) +import Data.Vector.Fusion.Stream.Monadic (Step (Done, Yield), Stream (Stream)) +import Data.Word (Word8) +import GHC.Exts (ByteArray#, Int (I#), Int#, MutableByteArray#) +import GHC.IO (unsafeIOToST) import qualified Data.Primitive as PM +import qualified Data.Primitive.Unlifted.Array as PM import qualified GHC.Exts as Exts -- | Count the number of times the byte appears in the sequence. count :: Word8 -> Bytes -> Int -count !b (Bytes{array=ByteArray arr,offset,length}) = +count !b (Bytes {array = ByteArray arr, offset, length}) = count_ba arr offset length b --- | Break a byte sequence into pieces separated by the byte argument, --- consuming the delimiter. This function is a good producer for list --- fusion. It is common to immidiately consume the results of @split@ --- with @foldl'@, @traverse_@, @foldlM@, and being a good producer helps --- in this situation. +{- | Variant of 'split' that returns an array of unsliced byte sequences. +Unlike 'split', this is not a good producer for list fusion. (It does +not return a list, so it could not be.) Prefer 'split' if the result +is going to be consumed exactly once by a good consumer. Prefer 'splitU' +if the result of the split is going to be around for a while and +inspected multiple times. +-} +splitU :: Word8 -> Bytes -> UnliftedArray ByteArray +splitU !w !bs = + let !lens = splitLengthsAlt w bs + !lensSz = PM.sizeofPrimArray lens + in splitCommonU lens lensSz bs + +{- | Variant of 'splitU' that drops the trailing element. See 'splitInit' +for an explanation of why this may be useful. +-} +splitInitU :: Word8 -> Bytes -> UnliftedArray ByteArray +splitInitU !w !bs = + let !lens = splitLengthsAlt w bs + !lensSz = PM.sizeofPrimArray lens + in splitCommonU lens (lensSz - 1) bs + +-- Internal function +splitCommonU :: + PrimArray Int -> -- array of segment lengths + Int -> -- number of lengths to consider + Bytes -> + UnliftedArray ByteArray +splitCommonU !lens !lensSz Bytes {array, offset = arrIx0} = runST do + dst <- PM.unsafeNewUnliftedArray lensSz + let go !lenIx !arrIx = + if lenIx < lensSz + then do + let !len = PM.indexPrimArray lens lenIx + buf <- PM.newByteArray len + PM.copyByteArray buf 0 array arrIx len + buf' <- PM.unsafeFreezeByteArray buf + PM.writeUnliftedArray dst lenIx buf' + go (lenIx + 1) (arrIx + len + 1) + else pure () + go 0 arrIx0 + PM.unsafeFreezeUnliftedArray dst + +{- | Break a byte sequence into pieces separated by the byte argument, +consuming the delimiter. This function is a good producer for list +fusion. It is common to immidiately consume the results of @split@ +with @foldl'@, @traverse_@, @foldlM@, and being a good producer helps +in this situation. + +Note: this function differs from its counterpart in @bytestring@. +If the byte sequence is empty, this returns a singleton list with +the empty byte sequence. +-} split :: Word8 -> Bytes -> [Bytes] -{-# inline split #-} -split !w !bs@Bytes{array,offset=arrIx0} = Exts.build - (\g x0 -> - let go !lenIx !arrIx = if lenIx < lensSz - then let !len = PM.indexPrimArray lens lenIx in - g (Bytes array arrIx len) (go (lenIx + 1) (arrIx + len + 1)) - else x0 - in go 0 arrIx0 - ) - where - !lens = splitLengths w bs +{-# INLINE split #-} +split !w !bs@Bytes {array, offset = arrIx0} = + Exts.build + ( \g x0 -> + let go !lenIx !arrIx = + if lenIx < lensSz + then + let !len = PM.indexPrimArray lens lenIx + in g (Bytes array arrIx len) (go (lenIx + 1) (arrIx + len + 1)) + else x0 + in go 0 arrIx0 + ) + where + !lens = splitLengthsAlt w bs !lensSz = PM.sizeofPrimArray lens --- | Variant of 'split' that drops the trailing element. This behaves --- correctly even if the byte sequence is empty. +{- | Variant of 'split' that intended for use with stream fusion rather +than @build@-@foldr@ fusion. +-} +splitStream :: forall m. (Applicative m) => Word8 -> Bytes -> Stream m Bytes +{-# INLINE [1] splitStream #-} +splitStream !w !bs@Bytes {array, offset = arrIx0} = Stream step (IntPair 0 arrIx0) + where + !lens = splitLengthsAlt w bs + !lensSz = PM.sizeofPrimArray lens + {-# INLINE [0] step #-} + step :: IntPair -> m (Step IntPair Bytes) + step (IntPair lenIx arrIx) = + if lenIx < lensSz + then do + let !len = PM.indexPrimArray lens lenIx + !element = Bytes array arrIx len + !acc = IntPair (lenIx + 1) (arrIx + len + 1) + pure (Yield element acc) + else pure Done + +{- | Variant of 'split' that returns the result as a 'NonEmpty' +instead of @[]@. This is also eligible for stream fusion. +-} +splitNonEmpty :: Word8 -> Bytes -> NonEmpty Bytes +{-# INLINE splitNonEmpty #-} +splitNonEmpty !w !bs@Bytes {array, offset = arrIx0} = + Bytes array arrIx0 len0 + :| Exts.build + ( \g x0 -> + let go !lenIx !arrIx = + if lenIx < lensSz + then + let !len = PM.indexPrimArray lens lenIx + in g (Bytes array arrIx len) (go (lenIx + 1) (arrIx + len + 1)) + else x0 + in go 1 (1 + (arrIx0 + len0)) + ) + where + !lens = splitLengthsAlt w bs + !lensSz = PM.sizeofPrimArray lens + !len0 = PM.indexPrimArray lens 0 :: Int + +{- | Variant of 'split' that drops the trailing element. This behaves +correctly even if the byte sequence is empty. This is a good producer +for list fusion. This is useful when splitting a text file +into lines. + +mandates that text files end with a newline, so the list resulting +from 'split' always has an empty byte sequence as its last element. +With 'splitInit', that unwanted element is discarded. +-} splitInit :: Word8 -> Bytes -> [Bytes] -{-# inline splitInit #-} -splitInit !w !bs@Bytes{array,offset=arrIx0} = Exts.build - (\g x0 -> - let go !lenIx !arrIx = if lenIx < lensSz - then let !len = PM.indexPrimArray lens lenIx in - g (Bytes array arrIx len) (go (lenIx + 1) (arrIx + len + 1)) - else x0 - in go 0 arrIx0 - ) - where +{-# INLINE splitInit #-} +splitInit !w !bs@Bytes {array, offset = arrIx0} = + Exts.build + ( \g x0 -> + let go !lenIx !arrIx = + if lenIx < lensSz + then + let !len = PM.indexPrimArray lens lenIx + in g (Bytes array arrIx len) (go (lenIx + 1) (arrIx + len + 1)) + else x0 + in go 0 arrIx0 + ) + where -- Remember, the resulting array from splitLengthsAlt always has -- a length of at least one. !lens = splitLengthsAlt w bs !lensSz = PM.sizeofPrimArray lens - 1 -splitLengths :: Word8 -> Bytes -> PrimArray Int -{-# inline splitLengths #-} -splitLengths (W8# b) Bytes{array=ByteArray arr,offset=I# off,length=I# len} = - PrimArray (splitLengths# b arr off len) - -- Internal function. This is just like splitLengths except that -- it does not treat the empty byte sequences specially. The result -- for that byte sequence is a singleton array with the element zero. splitLengthsAlt :: Word8 -> Bytes -> PrimArray Int -splitLengthsAlt b Bytes{array=ByteArray arr#,offset=off,length=len} = runPrimArrayST do +splitLengthsAlt b Bytes {array = ByteArray arr#, offset = off, length = len} = runPrimArrayST do let !n = count_ba arr# off len b - dst@(MutablePrimArray dst# ) :: MutablePrimArray s Int <- PM.newPrimArray (n + 1) - total <- unsafeIOToST (memchr_ba_many arr# off dst# n b) + dst@(MutablePrimArray dst#) :: MutablePrimArray s Int <- PM.newPrimArray (n + 1) + total <- unsafeIOToST (memchr_ba_many arr# off len dst# n b) PM.writePrimArray dst n (len - total) PM.unsafeFreezePrimArray dst --- Internal function. When the argument is the empty byte sequence, this --- returns an empty array of offsets. -splitLengths# :: Word# -> ByteArray# -> Int# -> Int# -> ByteArray# -{-# noinline splitLengths# #-} -splitLengths# b# arr# off# len# = result - where - b = W8# b# - off = I# off# - len = I# len# - -- We make 0 a special case for compatibility with the behavior - -- that the bytestring library provides. - !(PrimArray result) = runPrimArrayST $ case len of - 0 -> do - marr <- PM.newByteArray 0 - ByteArray res# <- PM.unsafeFreezeByteArray marr - pure (PrimArray res# ) - _ -> do - let !n = count_ba arr# off len b - dst@(MutablePrimArray dst# ) :: MutablePrimArray s Int <- PM.newPrimArray (n + 1) - total <- unsafeIOToST (memchr_ba_many arr# off dst# n b) - PM.writePrimArray dst n (len - total) - PM.unsafeFreezePrimArray dst +foreign import ccall unsafe "bs_custom.h memchr_ba_many" + memchr_ba_many :: + ByteArray# -> Int -> Int -> MutableByteArray# s -> Int -> Word8 -> IO Int -foreign import ccall unsafe "bs_custom.h memchr_ba_many" memchr_ba_many - :: ByteArray# -> Int -> MutableByteArray# s -> Int -> Word8 -> IO Int +foreign import ccall unsafe "bs_custom.h count_ba" + count_ba :: + ByteArray# -> Int -> Int -> Word8 -> Int -foreign import ccall unsafe "bs_custom.h count_ba" count_ba - :: ByteArray# -> Int -> Int -> Word8 -> Int +{- | Split a byte sequence on the first occurrence of the target +byte. The target is removed from the result. For example: + +>>> split1 0xA [0x1,0x2,0xA,0xB] +Just ([0x1,0x2],[0xB]) +-} +split1 :: Word8 -> Bytes -> Maybe (Bytes, Bytes) +{-# INLINE split1 #-} +split1 w b@(Bytes arr off len) = case elemIndexLoop# w b of + (-1#) -> Nothing + i# -> + let i = I# i# + in Just (Bytes arr off (i - off), Bytes arr (i + 1) (len - (1 + i - off))) + +{- | Split a byte sequence on the first and second occurrences +of the target byte. The target is removed from the result. +For example: + +>>> split2 0xA [0x1,0x2,0xA,0xB,0xA,0xA,0xA] +Just ([0x1,0x2],[0xB],[0xA,0xA]) +-} +split2 :: Word8 -> Bytes -> Maybe (Bytes, Bytes, Bytes) +{-# INLINE split2 #-} +split2 w b@(Bytes arr off len) = case elemIndexLoop# w b of + (-1#) -> Nothing + i# -> + let i = I# i# + in case elemIndexLoop# w (Bytes arr (i + 1) (len - (1 + i - off))) of + (-1#) -> Nothing + j# -> + let j = I# j# + in Just + ( Bytes arr off (i - off) + , Bytes arr (i + 1) (j - (i + 1)) + , Bytes arr (j + 1) (len - (1 + j - off)) + ) + +{- | Split a byte sequence on the first, second, and third occurrences +of the target byte. The target is removed from the result. +For example: + +>>> split3 0xA [0x1,0x2,0xA,0xB,0xA,0xA,0xA] +Just ([0x1,0x2],[0xB],[],[0xA]) +-} +split3 :: Word8 -> Bytes -> Maybe (Bytes, Bytes, Bytes, Bytes) +{-# INLINE split3 #-} +split3 w b@(Bytes arr off len) = case elemIndexLoop# w b of + (-1#) -> Nothing + i# -> + let i = I# i# + in case elemIndexLoop# w (Bytes arr (i + 1) (len - (1 + i - off))) of + (-1#) -> Nothing + j# -> + let j = I# j# + in case elemIndexLoop# w (Bytes arr (j + 1) (len - (1 + j - off))) of + (-1#) -> Nothing + k# -> + let k = I# k# + in Just + ( Bytes arr off (i - off) + , Bytes arr (i + 1) (j - (i + 1)) + , Bytes arr (j + 1) (k - (j + 1)) + , Bytes arr (k + 1) (len - (1 + k - off)) + ) + +{- | Split a byte sequence on the first, second, third, and fourth +occurrences of the target byte. The target is removed from the result. +For example: + +>>> split4 0xA [0x1,0x2,0xA,0xB,0xA,0xA,0xA] +Just ([0x1,0x2],[0xB],[],[],[]) +-} +split4 :: Word8 -> Bytes -> Maybe (Bytes, Bytes, Bytes, Bytes, Bytes) +{-# INLINE split4 #-} +split4 w b@(Bytes arr off len) = case elemIndexLoop# w b of + (-1#) -> Nothing + i# -> + let i = I# i# + in case elemIndexLoop# w (Bytes arr (i + 1) (len - (1 + i - off))) of + (-1#) -> Nothing + j# -> + let j = I# j# + in case elemIndexLoop# w (Bytes arr (j + 1) (len - (1 + j - off))) of + (-1#) -> Nothing + k# -> + let k = I# k# + in case elemIndexLoop# w (Bytes arr (k + 1) (len - (1 + k - off))) of + (-1#) -> Nothing + m# -> + let m = I# m# + in Just + ( Bytes arr off (i - off) + , Bytes arr (i + 1) (j - (i + 1)) + , Bytes arr (j + 1) (k - (j + 1)) + , Bytes arr (k + 1) (m - (k + 1)) + , Bytes arr (m + 1) (len - (1 + m - off)) + ) + +-- This returns the offset into the byte array. This is not an index +-- that will mean anything to the end user, so it cannot be returned +-- to them. +-- +-- Exported for use in other internal modules because it is needed in +-- Data.Bytes.Search. +elemIndexLoop# :: Word8 -> Bytes -> Int# +{-# INLINE elemIndexLoop# #-} +elemIndexLoop# !w (Bytes arr off@(I# off#) len) = case len of + 0 -> (-1#) + _ -> + if PM.indexByteArray arr off == w + then off# + else elemIndexLoop# w (Bytes arr (off + 1) (len - 1)) + +-- Variant of elemIndexLoop# that starts at the end. Similarly, returns +-- negative one if the element is not found. +elemIndexLoopBackwards# :: Word8 -> ByteArray -> Int -> Int -> Int# +elemIndexLoopBackwards# !w !arr !start !pos@(I# pos#) = + if pos < start + then (-1#) + else + if PM.indexByteArray arr pos == w + then pos# + else elemIndexLoopBackwards# w arr start (pos - 1) + +{- | Split a byte sequence on the last occurrence of the target +byte. The target is removed from the result. For example: + +>>> split1 0xA [0x1,0x2,0xA,0xB,0xA,0xC] +Just ([0x1,0x2,0xA,0xB],[0xC]) +-} +splitEnd1 :: Word8 -> Bytes -> Maybe (Bytes, Bytes) +{-# INLINE splitEnd1 #-} +splitEnd1 !w (Bytes arr off len) = case elemIndexLoopBackwards# w arr off (off + len - 1) of + (-1#) -> Nothing + i# -> + let i = I# i# + in Just (Bytes arr off (i - off), Bytes arr (i + 1) (len - (1 + i - off))) diff --git a/src/Data/Bytes/Chunks.hs b/src/Data/Bytes/Chunks.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Chunks.hs @@ -0,0 +1,426 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} + +{- | Chunks of bytes. This is useful as a target for a builder +or as a way to read a large amount of whose size is unknown +in advance. Structurally, this type is similar to +@Data.ByteString.Lazy.ByteString@. However, the type in this +module is strict in its spine. Additionally, none of the +@Handle@ functions perform lazy I\/O. +-} +module Data.Bytes.Chunks + ( -- * Types + Chunks (..) + + -- * Properties + , length + , null + + -- * Manipulate + , cons + , concat + , concatPinned + , concatU + , concatPinnedU + , concatByteString + , reverse + , reverseOnto + , replicate + , replicateByte + + -- * Folds + , foldl' + + -- * Splitting + , split + + -- * Hashing + , fnv1a32 + , fnv1a64 + + -- * Create + , fromBytes + , fromByteArray + + -- * Copy to buffer + , unsafeCopy + + -- * I\/O with Handles + , hGetContents + , readFile + , hPut + , writeFile + ) where + +import Prelude hiding (Foldable (..), concat, readFile, replicate, reverse, writeFile) + +import Control.Exception (IOException, catch) +import Control.Monad.ST.Run (runIntByteArrayST) +import Data.Bits (xor) +import Data.ByteString (ByteString) +import Data.Bytes.Types (Bytes (Bytes)) +import Data.Primitive (ByteArray (..), MutableByteArray (..)) +import Data.Word (Word32, Word64, Word8) +import GHC.Exts (ByteArray#, Int (I#), Int#, MutableByteArray#, State#, (+#)) +import GHC.ST (ST (..)) +import System.IO (Handle, IOMode (ReadMode, WriteMode), hFileSize, withBinaryFile) + +import qualified Data.Bytes.Byte as Byte +import qualified Data.Bytes.IO as IO +import qualified Data.Bytes.Pure as Bytes +import qualified Data.Bytes.Types as B +import qualified Data.Primitive as PM +import qualified GHC.Exts as Exts + +-- | A cons-list of byte sequences. +data Chunks + = ChunksCons {-# UNPACK #-} !Bytes !Chunks + | ChunksNil + deriving stock (Show) + +instance Semigroup Chunks where + ChunksNil <> a = a + cs@(ChunksCons _ _) <> ChunksNil = cs + as@(ChunksCons _ _) <> bs@(ChunksCons _ _) = + reverseOnto bs (reverse as) + +instance Monoid Chunks where + mempty = ChunksNil + +-- | This uses @concat@ to form an equivalence class. +instance Eq Chunks where + -- TODO: There is a more efficient way to do this, but + -- it is tedious. + a == b = concat a == concat b + +-- | Add a byte sequence to the beginning. +cons :: Bytes -> Chunks -> Chunks +{-# INLINE cons #-} +cons = ChunksCons + +{- | Repeat the byte sequence over and over. Returns empty chunks when given +a negative repetition count. +-} +replicate :: + Bytes -> + -- | Number of times to repeat the sequence. + Int -> + Chunks +replicate !b@(Bytes _ _ len) !n + | n <= 0 = ChunksNil + | len == 0 = ChunksNil + | otherwise = go n ChunksNil + where + -- Implementation note: We do not have to reverse the chunks at the end. + go i !acc = case i of + 0 -> acc + _ -> go (i - 1) (ChunksCons b acc) + +{- | Repeat the byte over and over. This builds a single byte array that +is at most 64KiB and shares that across every @ChunksCons@ cell. + +An as example, creating a 2GiB chunks this way would use 64KiB for the +byte array, and there would be the additional overhead of the 2^15 +@ChunksCons@ data constructors. On a 64-bit platform, @ChunksCons@ +takes 40 bytes, so the total memory consumption would be +@2^16 + 40 * 2^15@, which is roughly 1.37MB. The same reasoning +shows that it takes about 83.95MB to represent a 128GiB chunks. + +The size of the shared payload is an implementation detail. Do not +rely on this function producing 64KiB chunks. The implementation might +one day change to something smarter that minimizes the memory footprint +for very large chunks. +-} +replicateByte :: + Word8 -> + -- | Number of times to replicate the byte + Int -> + Chunks +replicateByte !w !n + | n <= 0 = ChunksNil + | n < 65536 = ChunksCons (Bytes.replicate n w) ChunksNil + | otherwise = go (Bytes.replicateU 65536 w) n ChunksNil + where + go !shared !remaining !acc + | remaining == 0 = acc + | remaining < 65536 = ChunksCons (Bytes shared 0 remaining) acc + | otherwise = go shared (remaining - 65536) (ChunksCons (Bytes shared 0 65536) acc) + +-- | Are there any bytes in the chunked byte sequences? +null :: Chunks -> Bool +null = go + where + go ChunksNil = True + go (ChunksCons (Bytes _ _ len) xs) = case len of + 0 -> go xs + _ -> False + +{- | Variant of 'concat' that ensure that the resulting byte +sequence is pinned memory. +-} +concatPinned :: Chunks -> Bytes +concatPinned x = case x of + ChunksNil -> Bytes.emptyPinned + ChunksCons b y -> case y of + ChunksNil -> Bytes.pin b + ChunksCons c z -> case concatPinnedFollowing2 b c z of + (# len, r #) -> Bytes (ByteArray r) 0 (I# len) + +-- | Concatenate chunks into a strict bytestring. +concatByteString :: Chunks -> ByteString +concatByteString c = Bytes.pinnedToByteString (concatPinned c) + +-- | Concatenate chunks into a single contiguous byte sequence. +concat :: Chunks -> Bytes +concat x = case x of + ChunksNil -> Bytes.empty + ChunksCons b y -> case y of + ChunksNil -> b + ChunksCons c z -> case concatFollowing2 b c z of + (# len, r #) -> Bytes (ByteArray r) 0 (I# len) + +-- | Variant of 'concat' that returns an unsliced byte sequence. +concatU :: Chunks -> ByteArray +concatU x = case x of + ChunksNil -> mempty + ChunksCons b y -> case y of + ChunksNil -> Bytes.toByteArray b + ChunksCons c z -> case concatFollowing2 b c z of + (# _, r #) -> ByteArray r + +-- | Variant of 'concatPinned' that returns an unsliced pinned byte sequence. +concatPinnedU :: Chunks -> ByteArray +concatPinnedU x = case x of + ChunksNil -> Bytes.emptyPinnedU + ChunksCons b y -> case y of + ChunksNil -> Bytes.toPinnedByteArray b + ChunksCons c z -> case concatPinnedFollowing2 b c z of + (# _, r #) -> ByteArray r + +concatFollowing2 :: Bytes -> Bytes -> Chunks -> (# Int#, ByteArray# #) +concatFollowing2 = internalConcatFollowing2 PM.newByteArray + +concatPinnedFollowing2 :: Bytes -> Bytes -> Chunks -> (# Int#, ByteArray# #) +concatPinnedFollowing2 = internalConcatFollowing2 PM.newPinnedByteArray + +internalConcatFollowing2 :: + (forall s. Int -> ST s (MutableByteArray s)) -> + Bytes -> + Bytes -> + Chunks -> + (# Int#, ByteArray# #) +{-# INLINE internalConcatFollowing2 #-} +internalConcatFollowing2 + allocate + (Bytes {array = c, offset = coff, length = szc}) + (Bytes {array = d, offset = doff, length = szd}) + ds = + let !(I# x, ByteArray y) = runIntByteArrayST $ do + let !szboth = szc + szd + !len = chunksLengthGo szboth ds + dst <- allocate len + PM.copyByteArray dst 0 c coff szc + PM.copyByteArray dst szc d doff szd + -- Note: len2 will always be the same as len. + !len2 <- unsafeCopy dst szboth ds + result <- PM.unsafeFreezeByteArray dst + pure (len2, result) + in (# x, y #) + +-- | The total number of bytes in all the chunks. +length :: Chunks -> Int +length = chunksLengthGo 0 + +chunksLengthGo :: Int -> Chunks -> Int +chunksLengthGo !n ChunksNil = n +chunksLengthGo !n (ChunksCons (Bytes {B.length = len}) cs) = + chunksLengthGo (n + len) cs + +{- | Copy the contents of the chunks into a mutable array. +Precondition: The destination must have enough space to +house the contents. This is not checked. +-} +unsafeCopy :: + -- | Destination + MutableByteArray s -> + -- | Destination offset + Int -> + -- | Source + Chunks -> + -- | Returns the next index into the destination after the payload + ST s Int +{-# INLINE unsafeCopy #-} +unsafeCopy (MutableByteArray dst) (I# off) cs = + ST + ( \s0 -> case copy# dst off cs s0 of + (# s1, nextOff #) -> (# s1, I# nextOff #) + ) + +copy# :: MutableByteArray# s -> Int# -> Chunks -> State# s -> (# State# s, Int# #) +copy# _ off ChunksNil s0 = (# s0, off #) +copy# marr off (ChunksCons (Bytes {B.array, B.offset, B.length = len}) cs) s0 = + case Exts.copyByteArray# (unBa array) (unI offset) marr off (unI len) s0 of + s1 -> copy# marr (off +# unI len) cs s1 + +-- | Reverse chunks but not the bytes within each chunk. +reverse :: Chunks -> Chunks +reverse = reverseOnto ChunksNil + +{- | Variant of 'reverse' that allows the caller to provide +an initial list of chunks that the reversed chunks will +be pushed onto. +-} +reverseOnto :: Chunks -> Chunks -> Chunks +reverseOnto !x ChunksNil = x +reverseOnto !x (ChunksCons y ys) = + reverseOnto (ChunksCons y x) ys + +unI :: Int -> Int# +{-# INLINE unI #-} +unI (I# i) = i + +unBa :: ByteArray -> ByteArray# +{-# INLINE unBa #-} +unBa (ByteArray x) = x + +-- | Read a handle's entire contents strictly into chunks. +hGetContents :: Handle -> IO Chunks +hGetContents !h = hGetContentsCommon ChunksNil h + +-- | Read a handle's entire contents strictly into chunks. +hGetContentsHint :: Int -> Handle -> IO Chunks +hGetContentsHint !hint !h = do + c <- IO.hGet h hint + let !r = ChunksCons c ChunksNil + if Bytes.length c == hint + then pure r + else hGetContentsCommon r h + +hGetContentsCommon :: + Chunks -> -- reversed chunks + Handle -> + IO Chunks +hGetContentsCommon !acc0 !h = go acc0 + where + go !acc = do + c <- IO.hGet h chunkSize + let !r = ChunksCons c acc + if Bytes.length c == chunkSize + then go r + else pure $! reverse r + +{- | Read an entire file strictly into chunks. If reading from a +regular file, this makes an effort read the file into a single +chunk. +-} +readFile :: FilePath -> IO Chunks +readFile f = withBinaryFile f ReadMode $ \h -> do + -- Implementation copied from bytestring. + -- hFileSize fails if file is not regular file (like + -- /dev/null). Catch exception and try reading anyway. + filesz <- catch (hFileSize h) useZeroIfNotRegularFile + let hint = (fromIntegral filesz `max` 255) + 1 + hGetContentsHint hint h + where + -- Our initial size is one bigger than the file size so that in the + -- typical case we will read the whole file in one go and not have + -- to allocate any more chunks. We'll still do the right thing if the + -- file size is 0 or is changed before we do the read. + + useZeroIfNotRegularFile :: IOException -> IO Integer + useZeroIfNotRegularFile _ = return 0 + +chunkSize :: Int +chunkSize = 16384 - 16 + +-- | Create a list of chunks with a single chunk. +fromBytes :: Bytes -> Chunks +fromBytes !b = ChunksCons b ChunksNil + +-- | Variant of 'fromBytes' where the single chunk is unsliced. +fromByteArray :: ByteArray -> Chunks +fromByteArray !b = fromBytes (Bytes.fromByteArray b) + +-- | Left fold over all bytes in the chunks, strict in the accumulator. +foldl' :: (a -> Word8 -> a) -> a -> Chunks -> a +{-# INLINE foldl' #-} +foldl' g = go + where + go !a ChunksNil = a + go !a (ChunksCons c cs) = go (Bytes.foldl' g a c) cs + +-- | Hash byte sequence with 32-bit variant of FNV-1a. +fnv1a32 :: Chunks -> Word32 +fnv1a32 !b = + foldl' + ( \acc w -> (fromIntegral @Word8 @Word32 w `xor` acc) * 0x01000193 + ) + 0x811c9dc5 + b + +-- | Hash byte sequence with 64-bit variant of FNV-1a. +fnv1a64 :: Chunks -> Word64 +fnv1a64 !b = + foldl' + ( \acc w -> (fromIntegral @Word8 @Word64 w `xor` acc) * 0x00000100000001B3 + ) + 0xcbf29ce484222325 + b + +{- | Outputs 'Chunks' to the specified 'Handle'. This is implemented +with 'IO.hPut'. +-} +hPut :: Handle -> Chunks -> IO () +hPut h = go + where + go ChunksNil = pure () + go (ChunksCons c cs) = IO.hPut h c *> go cs + +{- | Write 'Chunks' to a file, replacing the previous contents of +the file. +-} +writeFile :: FilePath -> Chunks -> IO () +writeFile path cs = withBinaryFile path WriteMode (\h -> hPut h cs) + +{- | Break chunks of bytes into contiguous pieces separated by the +byte argument. This is a good producer for list fusion. For this +function to perform well, each chunk should contain multiple separators. +Any piece that spans multiple chunks must be copied. +-} +split :: Word8 -> Chunks -> [Bytes] +{-# INLINE split #-} +split !w !cs0 = + Exts.build + ( \g x0 -> + -- It is possible to optimize for the common case where a + -- piece does not span multiple chunks. However, such an + -- optimization would actually cause this to tail call in + -- two places rather than one and may actually adversely + -- affect performance. It hasn't been benchmarked. + let go !cs = case splitOnto ChunksNil w cs of + (hd, tl) -> + let !x = concat (reverse hd) + in case tl of + ChunksNil -> x0 + _ -> g x (go tl) + in go cs0 + ) + +splitOnto :: Chunks -> Word8 -> Chunks -> (Chunks, Chunks) +{-# INLINE splitOnto #-} +splitOnto !acc0 !w !cs0 = go acc0 cs0 + where + go !acc ChunksNil = (acc, ChunksNil) + go !acc (ChunksCons b bs) = case Byte.split1 w b of + Nothing -> go (ChunksCons b acc) bs + Just (hd, tl) -> + let !r1 = ChunksCons hd acc + !r2 = ChunksCons tl bs + in (r1, r2) diff --git a/src/Data/Bytes/Encode/BigEndian.hs b/src/Data/Bytes/Encode/BigEndian.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Encode/BigEndian.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Bytes.Encode.BigEndian + ( word16 + , word32 + , word64 + , int16 + , int32 + , int64 + ) where + +import Control.Monad.ST.Run (runByteArrayST) +import Data.Bits (unsafeShiftR) +import Data.Bytes.Types (Bytes) +import Data.Int (Int16, Int32, Int64) +import Data.Primitive (ByteArray) +import Data.Word (Word16, Word32, Word64, Word8) + +import qualified Data.Bytes.Pure as Pure +import qualified Data.Primitive as PM + +-- | Encode a 32-bit signed integer as 4 bytes. +int32 :: Int32 -> Bytes +{-# INLINE int32 #-} +int32 = word32 . fromIntegral @Int32 @Word32 + +-- | Encode a 32-bit unsigned integer as 4 bytes. +word32 :: Word32 -> Bytes +word32 !w = Pure.fromByteArray (word32U w) + +word32U :: Word32 -> ByteArray +word32U !w = runByteArrayST $ do + arr <- PM.newByteArray 4 + PM.writeByteArray arr 0 (fromIntegral @Word32 @Word8 (unsafeShiftR w 24)) + PM.writeByteArray arr 1 (fromIntegral @Word32 @Word8 (unsafeShiftR w 16)) + PM.writeByteArray arr 2 (fromIntegral @Word32 @Word8 (unsafeShiftR w 8)) + PM.writeByteArray arr 3 (fromIntegral @Word32 @Word8 w) + PM.unsafeFreezeByteArray arr + +-- | Encode a 16-bit signed integer as 4 bytes. +int16 :: Int16 -> Bytes +{-# INLINE int16 #-} +int16 = word16 . fromIntegral @Int16 @Word16 + +-- | Encode a 16-bit unsigned integer as 4 bytes. +word16 :: Word16 -> Bytes +word16 !w = Pure.fromByteArray (word16U w) + +word16U :: Word16 -> ByteArray +word16U !w = runByteArrayST $ do + arr <- PM.newByteArray 2 + PM.writeByteArray arr 0 (fromIntegral @Word16 @Word8 (unsafeShiftR w 8)) + PM.writeByteArray arr 1 (fromIntegral @Word16 @Word8 w) + PM.unsafeFreezeByteArray arr + +-- | Encode a 16-bit signed integer as 4 bytes. +int64 :: Int64 -> Bytes +{-# INLINE int64 #-} +int64 = word64 . fromIntegral @Int64 @Word64 + +-- | Encode a 16-bit unsigned integer as 4 bytes. +word64 :: Word64 -> Bytes +word64 !w = Pure.fromByteArray (word64U w) + +word64U :: Word64 -> ByteArray +word64U !w = runByteArrayST $ do + arr <- PM.newByteArray 8 + PM.writeByteArray arr 0 (fromIntegral @Word64 @Word8 (unsafeShiftR w 56)) + PM.writeByteArray arr 1 (fromIntegral @Word64 @Word8 (unsafeShiftR w 48)) + PM.writeByteArray arr 2 (fromIntegral @Word64 @Word8 (unsafeShiftR w 40)) + PM.writeByteArray arr 3 (fromIntegral @Word64 @Word8 (unsafeShiftR w 32)) + PM.writeByteArray arr 4 (fromIntegral @Word64 @Word8 (unsafeShiftR w 24)) + PM.writeByteArray arr 5 (fromIntegral @Word64 @Word8 (unsafeShiftR w 16)) + PM.writeByteArray arr 6 (fromIntegral @Word64 @Word8 (unsafeShiftR w 8)) + PM.writeByteArray arr 7 (fromIntegral @Word64 @Word8 w) + PM.unsafeFreezeByteArray arr diff --git a/src/Data/Bytes/Encode/LittleEndian.hs b/src/Data/Bytes/Encode/LittleEndian.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Encode/LittleEndian.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Bytes.Encode.LittleEndian + ( word16 + , word32 + , word64 + , int16 + , int32 + , int64 + ) where + +import Control.Monad.ST.Run (runByteArrayST) +import Data.Bits (unsafeShiftR) +import Data.Bytes.Types (Bytes) +import Data.Int (Int16, Int32, Int64) +import Data.Primitive (ByteArray) +import Data.Word (Word16, Word32, Word64, Word8) + +import qualified Data.Bytes.Pure as Pure +import qualified Data.Primitive as PM + +-- | Encode a 32-bit signed integer as 4 bytes. +int32 :: Int32 -> Bytes +{-# INLINE int32 #-} +int32 = word32 . fromIntegral @Int32 @Word32 + +-- | Encode a 32-bit unsigned integer as 4 bytes. +word32 :: Word32 -> Bytes +word32 !w = Pure.fromByteArray (word32U w) + +word32U :: Word32 -> ByteArray +word32U !w = runByteArrayST $ do + arr <- PM.newByteArray 4 + PM.writeByteArray arr 3 (fromIntegral @Word32 @Word8 (unsafeShiftR w 24)) + PM.writeByteArray arr 2 (fromIntegral @Word32 @Word8 (unsafeShiftR w 16)) + PM.writeByteArray arr 1 (fromIntegral @Word32 @Word8 (unsafeShiftR w 8)) + PM.writeByteArray arr 0 (fromIntegral @Word32 @Word8 w) + PM.unsafeFreezeByteArray arr + +-- | Encode a 16-bit signed integer as 4 bytes. +int16 :: Int16 -> Bytes +{-# INLINE int16 #-} +int16 = word16 . fromIntegral @Int16 @Word16 + +-- | Encode a 16-bit unsigned integer as 4 bytes. +word16 :: Word16 -> Bytes +word16 !w = Pure.fromByteArray (word16U w) + +word16U :: Word16 -> ByteArray +word16U !w = runByteArrayST $ do + arr <- PM.newByteArray 2 + PM.writeByteArray arr 1 (fromIntegral @Word16 @Word8 (unsafeShiftR w 8)) + PM.writeByteArray arr 0 (fromIntegral @Word16 @Word8 w) + PM.unsafeFreezeByteArray arr + +-- | Encode a 16-bit signed integer as 4 bytes. +int64 :: Int64 -> Bytes +{-# INLINE int64 #-} +int64 = word64 . fromIntegral @Int64 @Word64 + +-- | Encode a 16-bit unsigned integer as 4 bytes. +word64 :: Word64 -> Bytes +word64 !w = Pure.fromByteArray (word64U w) + +word64U :: Word64 -> ByteArray +word64U !w = runByteArrayST $ do + arr <- PM.newByteArray 8 + PM.writeByteArray arr 7 (fromIntegral @Word64 @Word8 (unsafeShiftR w 56)) + PM.writeByteArray arr 6 (fromIntegral @Word64 @Word8 (unsafeShiftR w 48)) + PM.writeByteArray arr 5 (fromIntegral @Word64 @Word8 (unsafeShiftR w 40)) + PM.writeByteArray arr 4 (fromIntegral @Word64 @Word8 (unsafeShiftR w 32)) + PM.writeByteArray arr 3 (fromIntegral @Word64 @Word8 (unsafeShiftR w 24)) + PM.writeByteArray arr 2 (fromIntegral @Word64 @Word8 (unsafeShiftR w 16)) + PM.writeByteArray arr 1 (fromIntegral @Word64 @Word8 (unsafeShiftR w 8)) + PM.writeByteArray arr 0 (fromIntegral @Word64 @Word8 w) + PM.unsafeFreezeByteArray arr diff --git a/src/Data/Bytes/IO.hs b/src/Data/Bytes/IO.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/IO.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedTuples #-} + +module Data.Bytes.IO + ( hGet + , hPut + ) where + +import Data.Bytes.Pure (contents, pin) +import Data.Bytes.Types (Bytes (Bytes)) +import Data.Primitive (ByteArray (..), MutableByteArray) +import qualified Data.Primitive as PM +import Data.Word (Word8) +import Foreign.Ptr (Ptr) +import qualified GHC.Exts as Exts +import GHC.IO (IO (IO)) +import System.IO (Handle) +import qualified System.IO as IO + +{- | Read 'Bytes' directly from the specified 'Handle'. The resulting +'Bytes' are pinned. This is implemented with 'IO.hGetBuf'. +-} +hGet :: Handle -> Int -> IO Bytes +hGet h i = createPinnedAndTrim i (\p -> IO.hGetBuf h p i) + +{- | Outputs 'Bytes' to the specified 'Handle'. This is implemented +with 'IO.hPutBuf'. +-} +hPut :: Handle -> Bytes -> IO () +hPut h b0 = do + let b1@(Bytes arr _ len) = pin b0 + IO.hPutBuf h (contents b1) len + touchByteArrayIO arr + +-- Only used internally. +createPinnedAndTrim :: Int -> (Ptr Word8 -> IO Int) -> IO Bytes +{-# INLINE createPinnedAndTrim #-} +createPinnedAndTrim maxSz f = do + arr@(PM.MutableByteArray arr#) <- PM.newPinnedByteArray maxSz + sz <- f (PM.mutableByteArrayContents arr) + touchMutableByteArrayIO arr + PM.shrinkMutablePrimArray (PM.MutablePrimArray @Exts.RealWorld @Word8 arr#) sz + r <- PM.unsafeFreezeByteArray arr + pure (Bytes r 0 sz) + +touchMutableByteArrayIO :: MutableByteArray s -> IO () +touchMutableByteArrayIO (PM.MutableByteArray x) = + IO (\s -> (# Exts.touch# x s, () #)) + +touchByteArrayIO :: ByteArray -> IO () +touchByteArrayIO (ByteArray x) = + IO (\s -> (# Exts.touch# x s, () #)) diff --git a/src/Data/Bytes/Indexed.hs b/src/Data/Bytes/Indexed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Indexed.hs @@ -0,0 +1,35 @@ +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language TypeOperators #-} + +module Data.Bytes.Indexed + ( ByteArrayN + , append + , length + , length# + ) where + +import Prelude hiding (length) + +import Data.Primitive (ByteArray(ByteArray)) +import Data.Bytes.Types (ByteArrayN(ByteArrayN)) +import GHC.TypeNats (type (+)) +import Arithmetic.Types (Nat, Nat#) + +import qualified Data.Primitive as PM +import qualified Arithmetic.Unsafe as Unsafe +import qualified GHC.Exts as Exts + +append :: ByteArrayN m -> ByteArrayN n -> ByteArrayN (m + n) +{-# inline append #-} +append (ByteArrayN x) (ByteArrayN y) = ByteArrayN (x <> y) + +-- | Recover a witness of the length. +length :: ByteArrayN n -> Nat n +{-# inline length #-} +length (ByteArrayN x) = Unsafe.Nat (PM.sizeofByteArray x) + +-- | Recover an unboxed witness of the length. +length# :: ByteArrayN n -> Nat# n +{-# inline length# #-} +length# (ByteArrayN (ByteArray x)) = Unsafe.Nat# (Exts.sizeofByteArray# x) diff --git a/src/Data/Bytes/Internal.hs b/src/Data/Bytes/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Internal.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} + +-- This needs to be in its own module to prevent a cyclic dependency +-- between UnliftedBytes and Data.Bytes.Types +module Data.Bytes.Internal + ( Bytes (..) + ) where + +import Control.Monad.ST (runST) +import Control.Monad.ST.Run (runByteArrayST) +import Data.Bytes.Internal.Show (showsSlice) +import Data.Primitive (ByteArray (..)) +import Data.Word (Word8) +import GHC.Exts (Int (I#), IsList (..), compareByteArrays#, isTrue#, sameMutableByteArray#, unsafeCoerce#) + +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Data.Primitive as PM + +-- | A slice of a 'ByteArray'. +data Bytes = Bytes + { array :: {-# UNPACK #-} !ByteArray + , offset :: {-# UNPACK #-} !Int + , length :: {-# UNPACK #-} !Int + } + +instance IsList Bytes where + type Item Bytes = Word8 + fromListN n xs = Bytes (fromListN n xs) 0 n + fromList xs = fromListN (L.length xs) xs + toList (Bytes arr off len) = toListLoop off len arr + +toListLoop :: Int -> Int -> ByteArray -> [Word8] +toListLoop !off !len !arr = + if len > 0 + then PM.indexByteArray arr off : toListLoop (off + 1) (len - 1) arr + else [] + +instance Show Bytes where + showsPrec _ (Bytes arr off len) s = showsSlice arr off len s + +instance Eq Bytes where + Bytes arr1 off1 len1 == Bytes arr2 off2 len2 + | len1 /= len2 = False + | sameByteArray arr1 arr2 && off1 == off2 = True + | otherwise = compareByteArrays arr1 off1 arr2 off2 len1 == EQ + +instance Ord Bytes where + compare (Bytes arr1 off1 len1) (Bytes arr2 off2 len2) + | sameByteArray arr1 arr2 && off1 == off2 && len1 == len2 = EQ + | otherwise = compareByteArrays arr1 off1 arr2 off2 (min len1 len2) <> compare len1 len2 + +instance Semigroup Bytes where + -- TODO: Do the trick to move the data constructor to the outside + -- of runST. + Bytes arrA offA lenA <> Bytes arrB offB lenB = runST $ do + marr <- PM.newByteArray (lenA + lenB) + PM.copyByteArray marr 0 arrA offA lenA + PM.copyByteArray marr lenA arrB offB lenB + r <- PM.unsafeFreezeByteArray marr + pure (Bytes r 0 (lenA + lenB)) + +instance Monoid Bytes where + mempty = Bytes mempty 0 0 + mconcat [] = mempty + mconcat [x] = x + mconcat bs = Bytes r 0 fullLen + where + !fullLen = L.foldl' (\acc (Bytes _ _ len) -> acc + len) 0 bs + r = runByteArrayST $ do + marr <- PM.newByteArray fullLen + !_ <- + F.foldlM + ( \ !currLen (Bytes arr off len) -> do + PM.copyByteArray marr currLen arr off len + pure (currLen + len) + ) + 0 + bs + PM.unsafeFreezeByteArray marr + +compareByteArrays :: ByteArray -> Int -> ByteArray -> Int -> Int -> Ordering +{-# INLINE compareByteArrays #-} +compareByteArrays (ByteArray ba1#) (I# off1#) (ByteArray ba2#) (I# off2#) (I# n#) = + compare (I# (compareByteArrays# ba1# off1# ba2# off2# n#)) 0 + +sameByteArray :: ByteArray -> ByteArray -> Bool +{-# INLINE sameByteArray #-} +sameByteArray (ByteArray ba1#) (ByteArray ba2#) = + isTrue# (sameMutableByteArray# (unsafeCoerce# ba1#) (unsafeCoerce# ba2#)) diff --git a/src/Data/Bytes/Internal/Show.hs b/src/Data/Bytes/Internal/Show.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Internal/Show.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE BangPatterns #-} + +module Data.Bytes.Internal.Show + ( showsSlice + ) where + +import Data.Bits (unsafeShiftR, (.&.)) +import Data.Char (ord) +import Data.Primitive (ByteArray) +import Data.Word (Word8) +import GHC.Base (unsafeChr) + +import qualified Data.Primitive as PM + +showsSlice :: ByteArray -> Int -> Int -> String -> String +showsSlice arr off len s = + if len == 0 + then showString "[]" s + else + showString "[0x" $ + showHexDigitsWord8 (PM.indexByteArray arr off) $ + showHexLoop (off + 1) (len - 1) arr $ + showChar ']' $ + s + +showHexLoop :: Int -> Int -> ByteArray -> String -> String +showHexLoop !ix !len !arr s = + if len > 0 + then ',' : '0' : 'x' : showHexDigitsWord8 (PM.indexByteArray arr ix) (showHexLoop (ix + 1) (len - 1) arr s) + else s + +showHexDigitsWord8 :: Word8 -> String -> String +showHexDigitsWord8 !w s = word4ToChar (unsafeShiftR w 4) : word4ToChar (0x0F .&. w) : s + +word4ToChar :: Word8 -> Char +word4ToChar w = + if w < 10 + then unsafeChr (ord '0' + fromIntegral w) + else unsafeChr (ord 'a' + (fromIntegral w) - 10) diff --git a/src/Data/Bytes/Mutable.hs b/src/Data/Bytes/Mutable.hs --- a/src/Data/Bytes/Mutable.hs +++ b/src/Data/Bytes/Mutable.hs @@ -1,69 +1,87 @@ -{-# language BangPatterns #-} -{-# language LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{- | If you are interested in sub-arrays of 'MutableByteArray's (e.g. writing +quicksort), it would be grossly inefficient to make a copy of the sub-array. +On the other hand, it'd be really annoying to track limit indices by hand. + +This module defines the 'MutableBytes' type which exposes a standard array +interface for a sub-arrays without copying and without manual index +manipulation. For immutable arrays, see 'Data.Bytes'. +-} module Data.Bytes.Mutable ( -- * Types MutableBytes + -- * Filtering , takeWhile , dropWhile + -- * Unsafe Slicing , unsafeTake , unsafeDrop + -- * Conversion , fromMutableByteArray ) where -import Prelude hiding (takeWhile,dropWhile) +import Prelude hiding (dropWhile, takeWhile) -import Data.Bytes.Types (MutableBytes(MutableBytes)) +import Control.Monad.Primitive (PrimMonad, PrimState) +import Data.Bytes.Types (MutableBytes (MutableBytes)) import Data.Primitive (MutableByteArray) import Data.Word (Word8) -import Control.Monad.Primitive (PrimMonad,PrimState) import qualified Data.Primitive as PM --- | Take bytes while the predicate is true, aliasing the --- argument array. -takeWhile :: PrimMonad m - => (Word8 -> m Bool) - -> MutableBytes (PrimState m) - -> m (MutableBytes (PrimState m)) -{-# inline takeWhile #-} +{- | Take bytes while the predicate is true, aliasing the +argument array. +-} +takeWhile :: + (PrimMonad m) => + (Word8 -> m Bool) -> + MutableBytes (PrimState m) -> + m (MutableBytes (PrimState m)) +{-# INLINE takeWhile #-} takeWhile k b = do n <- countWhile k b pure (unsafeTake n b) --- | Drop bytes while the predicate is true, aliasing the --- argument array. -dropWhile :: PrimMonad m - => (Word8 -> m Bool) - -> MutableBytes (PrimState m) - -> m (MutableBytes (PrimState m)) -{-# inline dropWhile #-} +{- | Drop bytes while the predicate is true, aliasing the +argument array. +-} +dropWhile :: + (PrimMonad m) => + (Word8 -> m Bool) -> + MutableBytes (PrimState m) -> + m (MutableBytes (PrimState m)) +{-# INLINE dropWhile #-} dropWhile k b = do n <- countWhile k b pure (unsafeDrop n b) -- | Take the first @n@ bytes from the argument, aliasing it. unsafeTake :: Int -> MutableBytes s -> MutableBytes s -{-# inline unsafeTake #-} +{-# INLINE unsafeTake #-} unsafeTake n (MutableBytes arr off _) = MutableBytes arr off n --- | Drop the first @n@ bytes from the argument, aliasing it. --- The new length will be @len - n@. +{- | Drop the first @n@ bytes from the argument, aliasing it. +The new length will be @len - n@. +-} unsafeDrop :: Int -> MutableBytes s -> MutableBytes s -{-# inline unsafeDrop #-} +{-# INLINE unsafeDrop #-} unsafeDrop n (MutableBytes arr off len) = MutableBytes arr (off + n) (len - n) --- | Create a slice of 'MutableBytes' that spans the entire --- argument array. This aliases the argument. -fromMutableByteArray :: PrimMonad m - => MutableByteArray (PrimState m) - -> m (MutableBytes (PrimState m)) -{-# inline fromMutableByteArray #-} +{- | Create a slice of 'MutableBytes' that spans the entire +argument array. This aliases the argument. +-} +fromMutableByteArray :: + (PrimMonad m) => + MutableByteArray (PrimState m) -> + m (MutableBytes (PrimState m)) +{-# INLINE fromMutableByteArray #-} fromMutableByteArray mba = do sz <- PM.getSizeofMutableByteArray mba pure (MutableBytes mba 0 sz) @@ -72,14 +90,18 @@ -- predicate until the first non-match occurs. If all bytes -- match the predicate, this will return the length originally -- provided. -countWhile :: PrimMonad m - => (Word8 -> m Bool) - -> MutableBytes (PrimState m) - -> m Int -{-# inline countWhile #-} -countWhile k (MutableBytes arr off0 len0) = go off0 len0 0 where - go !off !len !n = if len > 0 - then (k =<< PM.readByteArray arr off) >>= \case - True -> go (off + 1) (len - 1) (n + 1) - False -> pure n - else pure n +countWhile :: + (PrimMonad m) => + (Word8 -> m Bool) -> + MutableBytes (PrimState m) -> + m Int +{-# INLINE countWhile #-} +countWhile k (MutableBytes arr off0 len0) = go off0 len0 0 + where + go !off !len !n = + if len > 0 + then + (k =<< PM.readByteArray arr off) >>= \case + True -> go (off + 1) (len - 1) (n + 1) + False -> pure n + else pure n diff --git a/src/Data/Bytes/Pure.hs b/src/Data/Bytes/Pure.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Pure.hs @@ -0,0 +1,501 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Bytes.Pure + ( empty + , emptyPinned + , emptyPinnedU + , pin + , contents + , unsafeCopy + , toByteArray + , toByteArrayClone + , toPinnedByteArray + , toPinnedByteArrayClone + , fromByteArray + , fromPrimArray + , length + , foldlM + , foldrM + , foldl + , foldl' + , foldr + , ifoldl' + , foldr' + , fnv1a32 + , fnv1a64 + , toByteString + , pinnedToByteString + , fromByteString + , fromLazyByteString + , unsafeDrop + , unsafeTake + , unsafeIndex + , unsafeHead + , map + , mapU + , null + , toShortByteString + , replicate + , replicateU + , splitTetragram1 + , findTetragramIndex + , countWhile + , countWhileEnd + , any + , all + ) where + +import Prelude hiding (Foldable (..), map, replicate, any, all) + +import Control.Monad.Primitive (PrimMonad, PrimState) +import Control.Monad.ST.Run (runByteArrayST) +import Data.Bits (unsafeShiftL, (.|.)) +import Data.Bits (xor) +import Data.ByteString (ByteString) +import Data.ByteString.Short.Internal (ShortByteString (SBS)) +import Data.Bytes.Types (Bytes (Bytes)) +import Data.Primitive (ByteArray (ByteArray), MutableByteArray, PrimArray (PrimArray)) +import Data.Word (Word32, Word64, Word8) +import Foreign.Ptr (Ptr, plusPtr) +import GHC.IO (unsafeIOToST) + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Internal as ByteString +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Internal as LBS +import qualified Data.ByteString.Unsafe as ByteString +import qualified Data.Primitive as PM +import qualified GHC.Exts as Exts +import qualified GHC.ForeignPtr as ForeignPtr + +-- | The empty byte sequence. +empty :: Bytes +empty = Bytes mempty 0 0 + +-- | The empty pinned byte sequence. +emptyPinned :: Bytes +emptyPinned = + Bytes + ( runByteArrayST + (PM.newPinnedByteArray 0 >>= PM.unsafeFreezeByteArray) + ) + 0 + 0 + +-- | The empty pinned byte sequence. +emptyPinnedU :: ByteArray +emptyPinnedU = + runByteArrayST + (PM.newPinnedByteArray 0 >>= PM.unsafeFreezeByteArray) + +{- | Yields a pinned byte sequence whose contents are identical to those +of the original byte sequence. If the @ByteArray@ backing the argument +was already pinned, this simply aliases the argument and does not perform +any copying. +-} +pin :: Bytes -> Bytes +pin b@(Bytes arr _ len) = case PM.isByteArrayPinned arr of + True -> b + False -> + Bytes + ( runByteArrayST do + dst <- PM.newPinnedByteArray len + unsafeCopy dst 0 b + PM.unsafeFreezeByteArray dst + ) + 0 + len + +{- | Convert the sliced 'Bytes' to an unsliced 'ByteArray'. This +reuses the array backing the sliced 'Bytes' if the slicing metadata +implies that all of the bytes are used. Otherwise, it makes a copy. +-} +toByteArray :: Bytes -> ByteArray +{-# INLINE toByteArray #-} +toByteArray b@(Bytes arr off len) + | off == 0, PM.sizeofByteArray arr == len = arr + | otherwise = toByteArrayClone b + +{- | Variant of 'toByteArray' that unconditionally makes a copy of +the array backing the sliced 'Bytes' even if the original array +could be reused. Prefer 'toByteArray'. +-} +toByteArrayClone :: Bytes -> ByteArray +{-# INLINE toByteArrayClone #-} +toByteArrayClone (Bytes arr off len) = runByteArrayST $ do + m <- PM.newByteArray len + PM.copyByteArray m 0 arr off len + PM.unsafeFreezeByteArray m + +{- | Copy the byte sequence into a mutable buffer. The buffer must have +enough space to accomodate the byte sequence, but this this is not +checked. +-} +unsafeCopy :: + (PrimMonad m) => + -- | Destination + MutableByteArray (PrimState m) -> + -- | Destination Offset + Int -> + -- | Source + Bytes -> + m () +{-# INLINE unsafeCopy #-} +unsafeCopy dst dstIx (Bytes src srcIx len) = + PM.copyByteArray dst dstIx src srcIx len + +-- | Create a slice of 'Bytes' that spans the entire argument array. +fromByteArray :: ByteArray -> Bytes +{-# INLINE fromByteArray #-} +fromByteArray b = Bytes b 0 (PM.sizeofByteArray b) + +-- | Create a slice of 'Bytes' that spans the entire 'PrimArray' of 8-bit words. +fromPrimArray :: PrimArray Word8 -> Bytes +{-# INLINE fromPrimArray #-} +fromPrimArray p@(PrimArray b) = Bytes (ByteArray b) 0 (PM.sizeofPrimArray p) + +-- | The length of a slice of bytes. +length :: Bytes -> Int +{-# INLINE length #-} +length (Bytes _ _ len) = len + +-- | Hash byte sequence with 32-bit variant of FNV-1a. +fnv1a32 :: Bytes -> Word32 +fnv1a32 !b = + foldl' + ( \acc w -> (fromIntegral @Word8 @Word32 w `xor` acc) * 0x01000193 + ) + 0x811c9dc5 + b + +-- | Hash byte sequence with 64-bit variant of FNV-1a. +fnv1a64 :: Bytes -> Word64 +fnv1a64 !b = + foldl' + ( \acc w -> (fromIntegral @Word8 @Word64 w `xor` acc) * 0x00000100000001B3 + ) + 0xcbf29ce484222325 + b + +-- | Left fold over bytes, non-strict in the accumulator. +foldl :: (a -> Word8 -> a) -> a -> Bytes -> a +{-# INLINE foldl #-} +foldl f a0 (Bytes arr off0 len0) = + go (off0 + len0 - 1) (len0 - 1) + where + go !off !ix = case ix of + (-1) -> a0 + _ -> f (go (off - 1) (ix - 1)) (PM.indexByteArray arr off) + +-- | Left fold over bytes, strict in the accumulator. +foldl' :: (a -> Word8 -> a) -> a -> Bytes -> a +{-# INLINE foldl' #-} +foldl' f a0 (Bytes arr off0 len0) = go a0 off0 len0 + where + go !a !off !len = case len of + 0 -> a + _ -> go (f a (PM.indexByteArray arr off)) (off + 1) (len - 1) + +-- | Left monadic fold over bytes, non-strict in the accumulator. +foldlM :: (Monad m) => (a -> Word8 -> m a) -> a -> Bytes -> m a +{-# INLINE foldlM #-} +foldlM f a0 (Bytes arr off0 len0) = go a0 off0 len0 + where + go a !off !len = case len of + 0 -> pure a + _ -> do + a' <- f a (PM.indexByteArray arr off) + go a' (off + 1) (len - 1) + +-- | Right fold over bytes, non-strict in the accumulator. +foldr :: (Word8 -> a -> a) -> a -> Bytes -> a +{-# INLINE foldr #-} +foldr f a0 (Bytes arr off0 len0) = go off0 len0 + where + go !off !len = case len of + 0 -> a0 + _ -> f (PM.indexByteArray arr off) (go (off + 1) (len - 1)) + +{- | Left fold over bytes, strict in the accumulator. The reduction function +is applied to each element along with its index. +-} +ifoldl' :: (a -> Int -> Word8 -> a) -> a -> Bytes -> a +{-# INLINE ifoldl' #-} +ifoldl' f a0 (Bytes arr off0 len0) = go a0 0 off0 len0 + where + go !a !ix !off !len = case len of + 0 -> a + _ -> go (f a ix (PM.indexByteArray arr off)) (ix + 1) (off + 1) (len - 1) + +-- | Right fold over bytes, strict in the accumulator. +foldr' :: (Word8 -> a -> a) -> a -> Bytes -> a +{-# INLINE foldr' #-} +foldr' f a0 (Bytes arr off0 len0) = + go a0 (off0 + len0 - 1) (len0 - 1) + where + go !a !off !ix = case ix of + (-1) -> a + _ -> go (f (PM.indexByteArray arr off) a) (off - 1) (ix - 1) + +-- | Right monadic fold over bytes, non-strict in the accumulator. +foldrM :: (Monad m) => (Word8 -> a -> m a) -> a -> Bytes -> m a +{-# INLINE foldrM #-} +foldrM f a0 (Bytes arr off0 len0) = + go a0 (off0 + len0 - 1) (len0 - 1) + where + go !a !off !ix = case ix of + (-1) -> pure a + _ -> do + a' <- f (PM.indexByteArray arr off) a + go a' (off - 1) (ix - 1) + +{- | Yields a pointer to the beginning of the byte sequence. It is only safe +to call this on a 'Bytes' backed by a pinned @ByteArray@. +-} +contents :: Bytes -> Ptr Word8 +{-# INLINE contents #-} +contents (Bytes arr off _) = plusPtr (PM.byteArrayContents arr) off + +{- | Convert the sliced 'Bytes' to an unsliced 'ByteArray'. This +reuses the array backing the sliced 'Bytes' if the slicing metadata +implies that all of the bytes are used and they are already pinned. +Otherwise, it makes a copy. +-} +toPinnedByteArray :: Bytes -> ByteArray +{-# INLINE toPinnedByteArray #-} +toPinnedByteArray b@(Bytes arr off len) + | off == 0, PM.sizeofByteArray arr == len, PM.isByteArrayPinned arr = arr + | otherwise = toPinnedByteArrayClone b + +{- | Variant of 'toPinnedByteArray' that unconditionally makes a copy of +the array backing the sliced 'Bytes' even if the original array +could be reused. Prefer 'toPinnedByteArray'. +-} +toPinnedByteArrayClone :: Bytes -> ByteArray +toPinnedByteArrayClone (Bytes arr off len) = runByteArrayST $ do + m <- PM.newPinnedByteArray len + PM.copyByteArray m 0 arr off len + PM.unsafeFreezeByteArray m + +{- | /O(n)/ when unpinned, /O(1)/ when pinned. Create a 'ByteString' from +a byte sequence. This only copies the byte sequence if it is not pinned. +-} +toByteString :: Bytes -> ByteString +toByteString !b = pinnedToByteString (pin b) + +{- | Convert a pinned 'Bytes' to a 'ByteString' +/O(1)/ Precondition: bytes are pinned. Behavior is undefined otherwise. +-} +pinnedToByteString :: Bytes -> ByteString +pinnedToByteString (Bytes y@(PM.ByteArray x) off len) = + ByteString.PS + ( ForeignPtr.ForeignPtr + (case plusPtr (PM.byteArrayContents y) off of Exts.Ptr p -> p) + (ForeignPtr.PlainPtr (Exts.unsafeCoerce# x)) + ) + 0 + len + +-- | /O(n)/ Copy a 'ByteString' to a byte sequence. +fromByteString :: ByteString -> Bytes +fromByteString !b = + Bytes + ( runByteArrayST $ unsafeIOToST $ do + dst@(PM.MutableByteArray dst#) <- PM.newByteArray len + ByteString.unsafeUseAsCString b $ \src -> do + PM.copyPtrToMutablePrimArray (PM.MutablePrimArray dst#) 0 src len + PM.unsafeFreezeByteArray dst + ) + 0 + len + where + !len = ByteString.length b + +-- | /O(n)/ Copy a lazy bytestring to a byte sequence. +fromLazyByteString :: LBS.ByteString -> Bytes +fromLazyByteString x = case LBS.length x of + 0 -> empty + n64 -> + let n = fromIntegral n64 :: Int + in Bytes + ( runByteArrayST $ unsafeIOToST $ do + dst@(PM.MutableByteArray dst#) <- PM.newByteArray n + let loop chunks !ix = case chunks of + LBS.Empty -> PM.unsafeFreezeByteArray dst + LBS.Chunk c cs -> do + let !len = ByteString.length c + ByteString.unsafeUseAsCString c $ \src -> do + PM.copyPtrToMutablePrimArray (PM.MutablePrimArray dst#) ix src len + loop cs (ix + len) + loop x 0 + ) + 0 + n + +-- | Drop the first @n@ bytes from the argument. Precondition: @n ≤ len@ +unsafeDrop :: Int -> Bytes -> Bytes +{-# INLINE unsafeDrop #-} +unsafeDrop n (Bytes arr off len) = + Bytes arr (off + n) (len - n) + +-- | Variant of 'map' that returns unsliced byte sequence. +mapU :: (Word8 -> Word8) -> Bytes -> ByteArray +{-# INLINE mapU #-} +mapU f (Bytes array ix0 len) = runByteArrayST do + dst <- PM.newByteArray len + let go !srcIx !dstIx = + if dstIx < len + then do + let w = PM.indexByteArray array srcIx :: Word8 + PM.writeByteArray dst dstIx (f w) + go (srcIx + 1) (dstIx + 1) + else PM.unsafeFreezeByteArray dst + go ix0 0 + +{- | Map over bytes in a sequence. The result has the same length as +the argument. +-} +map :: (Word8 -> Word8) -> Bytes -> Bytes +{-# INLINE map #-} +map f !b = Bytes (mapU f b) 0 (length b) + +-- | Is the byte sequence empty? +null :: Bytes -> Bool +{-# INLINE null #-} +null (Bytes _ _ len) = len == 0 + +-- | Take the first @n@ bytes from the argument. Precondition: @n ≤ len@ +unsafeTake :: Int -> Bytes -> Bytes +{-# INLINE unsafeTake #-} +unsafeTake n (Bytes arr off _) = + Bytes arr off n + +{- | Index into the byte sequence at the given position. This index +must be less than the length. +-} +unsafeIndex :: Bytes -> Int -> Word8 +{-# INLINE unsafeIndex #-} +unsafeIndex (Bytes arr off _) ix = PM.indexByteArray arr (off + ix) + +-- | Access the first byte. The given 'Bytes' must be non-empty. +{-# INLINE unsafeHead #-} +unsafeHead :: Bytes -> Word8 +unsafeHead bs = unsafeIndex bs 0 + +{- | Convert the sliced 'Bytes' to an unsliced 'ShortByteString'. This +reuses the array backing the sliced 'Bytes' if the slicing metadata +implies that all of the bytes are used. Otherwise, it makes a copy. +-} +toShortByteString :: Bytes -> ShortByteString +{-# INLINE toShortByteString #-} +toShortByteString !b = case toByteArray b of + PM.ByteArray x -> SBS x + +-- | Replicate a byte @n@ times. +replicate :: + -- | Desired length @n@ + Int -> + -- | Byte to replicate + Word8 -> + Bytes +replicate !n !w = Bytes (replicateU n w) 0 n + +-- | Variant of 'replicate' that returns a unsliced byte array. +replicateU :: Int -> Word8 -> ByteArray +replicateU !n !w = runByteArrayST do + arr <- PM.newByteArray n + PM.setByteArray arr 0 n w + PM.unsafeFreezeByteArray arr + +splitTetragram1 :: + Word8 -> + Word8 -> + Word8 -> + Word8 -> + Bytes -> + Maybe (Bytes, Bytes) +splitTetragram1 !w0 !w1 !w2 !w3 !b = case findTetragramIndex w0 w1 w2 w3 b of + Nothing -> Nothing + Just n -> Just (unsafeTake n b, unsafeDrop (n + 4) b) + +findTetragramIndex :: + Word8 -> + Word8 -> + Word8 -> + Word8 -> + Bytes -> + Maybe Int +findTetragramIndex !w0 !w1 !w2 !w3 (Bytes arr off len) = + if len < 4 + then Nothing + else + let !target = + unsafeShiftL (fromIntegral w0 :: Word32) 24 + .|. unsafeShiftL (fromIntegral w1 :: Word32) 16 + .|. unsafeShiftL (fromIntegral w2 :: Word32) 8 + .|. unsafeShiftL (fromIntegral w3 :: Word32) 0 + !end = off + len + go !ix !acc = + if acc == target + then + let n = ix - off + in Just (n - 4) + else + if ix < end + then + let !w = PM.indexByteArray arr ix :: Word8 + acc' = + (fromIntegral w :: Word32) + .|. unsafeShiftL acc 8 + in go (ix + 1) acc' + else Nothing + !acc0 = + unsafeShiftL (fromIntegral (PM.indexByteArray arr 0 :: Word8) :: Word32) 24 + .|. unsafeShiftL (fromIntegral (PM.indexByteArray arr 1 :: Word8) :: Word32) 16 + .|. unsafeShiftL (fromIntegral (PM.indexByteArray arr 2 :: Word8) :: Word32) 8 + .|. unsafeShiftL (fromIntegral (PM.indexByteArray arr 3 :: Word8) :: Word32) 0 + in go 4 acc0 + +-- Internal. The returns the number of bytes that match the +-- predicate until the first non-match occurs. If all bytes +-- match the predicate, this will return the length originally +-- provided. +countWhile :: (Word8 -> Bool) -> Bytes -> Int +{-# INLINE countWhile #-} +countWhile k (Bytes arr off0 len0) = go off0 len0 0 + where + go !off !len !n = + if len > 0 + then + if k (PM.indexByteArray arr off) + then go (off + 1) (len - 1) (n + 1) + else n + else n + +-- Internal. Variant of countWhile that starts from the end +-- of the string instead of the beginning. +countWhileEnd :: (Word8 -> Bool) -> Bytes -> Int +{-# INLINE countWhileEnd #-} +countWhileEnd k (Bytes arr off0 len0) = go (off0 + len0 - 1) (len0 - 1) 0 + where + go !off !len !n = + if len >= 0 + then + if k (PM.indexByteArray arr off) + then go (off - 1) (len - 1) (n + 1) + else n + else n + +-- | /O(n)/ Returns true if any byte in the sequence satisfies the predicate. +any :: (Word8 -> Bool) -> Bytes -> Bool +{-# INLINE any #-} +any f = foldr (\b r -> f b || r) False + +-- | /O(n)/ Returns true if all bytes in the sequence satisfy the predicate. +all :: (Word8 -> Bool) -> Bytes -> Bool +{-# INLINE all #-} +all f = foldr (\b r -> f b && r) True + diff --git a/src/Data/Bytes/Search.hs b/src/Data/Bytes/Search.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Search.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} + +-- This is broken out into a separate module to make it easier +-- to dump core and investigate performance issues. +module Data.Bytes.Search + ( findIndices + , replace + , isInfixOf + ) where + +import Prelude hiding (all, any, dropWhile, elem, foldl, foldr, length, map, null, readFile, replicate, takeWhile) + +import Control.Monad.ST.Run (runByteArrayST, runPrimArrayST) +import Data.Bits (finiteBitSize, shiftL, (.&.), (.|.)) +import Data.Bytes.Pure (length, unsafeHead, unsafeIndex) +import Data.Bytes.Types (Bytes (Bytes, array, offset)) +import Data.Primitive (ByteArray, PrimArray) +import GHC.Exts (Int (I#)) +import GHC.Word (Word32) + +import qualified Data.Bytes.Byte as Byte +import qualified Data.Bytes.Pure as Pure +import qualified Data.Bytes.Types as Types +import qualified Data.Primitive as PM + +-- Implementation Notes +-- ===================== +-- For karp rabin, there are some easy performance improvements +-- left on the table. The main optimization that has been done is making +-- sure that there is no unnecessary boxing of Int, Word32, or Bytes +-- going on. Here are some other things that have not been done: +-- + +-- * The hash is currently a Word32. It would be better to use either + +-- Word or Word64 for this. We would need for hashKey to be different. + +-- * In several places, we track an index into a Bytes. This index gets + +-- repeatedly added to the base offset as we loop over the bytes. We +-- could instead track the true offset instead of repeatedly +-- recalculating it. + +{- | Replace every non-overlapping occurrence of @needle@ in +@haystack@ with @replacement@. +-} +replace :: + -- | needle, must not be empty + Bytes -> + -- | replacement + Bytes -> + -- | haystack + Bytes -> + Bytes +{-# NOINLINE replace #-} +-- Implementation note: there is a lot of room to improve the performance +-- of this function. +replace !needle !replacement !haystack@Bytes {array = haystackArray, offset = haystackIndex, length = haystackLength} + | Pure.length needle == 0 = errorWithoutStackTrace "Data.Bytes.replace: needle of length zero" + | Pure.length haystack == 0 = Pure.empty + | Pure.length needle == 1 + , Pure.length replacement == 1 = + let !needle0 = unsafeIndex needle 0 + !replacement0 = unsafeIndex replacement 0 + in Pure.map (\w -> if w == needle0 then replacement0 else w) haystack + | otherwise = + let !hp = rollingHash needle + !ixs = findIndicesKarpRabin 0 hp needle haystackArray haystackIndex haystackLength + in Pure.fromByteArray (replaceIndices ixs replacement (Pure.length needle) haystackArray haystackIndex haystackLength) + +-- This is an internal function because it deals explicitly with +-- an offset into a byte array. +-- +-- Example: + +-- * haystack len: 39 + +-- * ixs: 7, 19, 33 + +-- * patLen: 5 + +-- * replacment: foo (len 3) + +-- We want to perform these copies: + +-- * src[0,7] -> dst[0,7] + +-- * foo -> dst[7,3] + +-- * src[12,7] -> dst[10,7] + +-- * foo -> dst[17,3] + +-- * src[24,9] -> dst[20,9] + +-- * foo -> dst[29,3] + +-- * src[38,1] -> dst[32,1] +replaceIndices :: PrimArray Int -> Bytes -> Int -> ByteArray -> Int -> Int -> ByteArray +replaceIndices !ixs !replacement !patLen !haystack !ix0 !len0 = runByteArrayST $ do + let !ixsLen = PM.sizeofPrimArray ixs + let !delta = Pure.length replacement - patLen + dst <- PM.newByteArray (len0 + ixsLen * delta) + let applyReplacement !ixIx !prevSrcIx = + if ixIx < ixsLen + then do + let !srcMatchIx = PM.indexPrimArray ixs ixIx + let !offset = ixIx * delta + let !dstIx = srcMatchIx + offset - ix0 + Pure.unsafeCopy + dst + (prevSrcIx + offset - ix0) + Bytes {array = haystack, offset = prevSrcIx, length = srcMatchIx - prevSrcIx} + Pure.unsafeCopy dst dstIx replacement + applyReplacement (ixIx + 1) (srcMatchIx + patLen) + else do + let !offset = ixIx * delta + Pure.unsafeCopy + dst + (prevSrcIx + offset - ix0) + Bytes {array = haystack, offset = prevSrcIx, length = (len0 + ix0) - prevSrcIx} + PM.unsafeFreezeByteArray dst + applyReplacement 0 ix0 + +-- | Find locations of non-overlapping instances of @needle@ within @haystack@. +findIndices :: + -- | needle + Bytes -> + -- | haystack + Bytes -> + PrimArray Int +findIndices needle Bytes {array, offset = off, length = len} + | needleLen == 0 = errorWithoutStackTrace "Data.Bytes.findIndices: needle with length zero" + | len == 0 = mempty + | otherwise = + let !hp = rollingHash needle + in findIndicesKarpRabin (negate off) hp needle array off len + where + needleLen = Pure.length needle + +-- Precondition: Haystack has non-zero length +-- Precondition: Pattern has non-zero length +-- Uses karp rabin to search. +-- Easy opportunity to improve implementation. Instead of having karpRabin +-- return two slices, we could have it just return a single index. +findIndicesKarpRabin :: + Int -> -- Output index modifier. Set to negated initial index to make slicing invisible in results. + Word32 -> -- Hash to search for (must agree with pattern) + Bytes -> -- Pattern to search for + ByteArray -> + Int -> -- initial index + Int -> -- length + PrimArray Int +findIndicesKarpRabin !ixModifier !hp !pat !haystack !ix0 !len0 = runPrimArrayST $ do + let dstLen = 1 + quot len0 (Pure.length pat) + dst <- PM.newPrimArray dstLen + let go !ix !len !ixIx = case karpRabin hp pat Bytes {array = haystack, offset = ix, length = len} of + (-1) -> do + PM.shrinkMutablePrimArray dst ixIx + PM.unsafeFreezePrimArray dst + skipCount -> do + let !advancement = skipCount - Pure.length pat + let !advancement' = advancement + Pure.length pat + PM.writePrimArray dst ixIx (ix + advancement + ixModifier) + let !ix' = ix + advancement' + go ix' (len - advancement') (ixIx + 1) + go ix0 len0 0 + +-- Output: Negative one means match not found. Other negative +-- numbers should not occur. Zero may occur. Positive number +-- means the number of bytes to skip to make it past the match. +breakSubstring :: + -- | String to search for + Bytes -> + -- | String to search in + Bytes -> + Int +breakSubstring !pat !haystack@(Bytes _ off0 _) = + case lp of + 0 -> 0 + 1 -> case Byte.elemIndexLoop# (unsafeHead pat) haystack of + (-1#) -> (-1) + off -> 1 + (I# off) - off0 + _ -> + if lp * 8 <= finiteBitSize (0 :: Word) + then shift haystack + else karpRabin (rollingHash pat) pat haystack + where + lp = length pat + {-# INLINE shift #-} + shift :: Bytes -> Int + shift !src + | length src < lp = (-1) + | otherwise = search (intoWord $ Pure.unsafeTake lp src) lp + where + intoWord :: Bytes -> Word + intoWord = Pure.foldl' (\w b -> (w `shiftL` 8) .|. fromIntegral b) 0 + wp = intoWord pat + mask = (1 `shiftL` (8 * lp)) - 1 + search :: Word -> Int -> Int + search !w !i + | w == wp = i + | length src <= i = (-1) + | otherwise = search w' (i + 1) + where + b = fromIntegral (Pure.unsafeIndex src i) + w' = mask .&. ((w `shiftL` 8) .|. b) + +-- Only used for karp rabin +rollingHash :: Bytes -> Word32 +{-# INLINE rollingHash #-} +rollingHash = Pure.foldl' (\h b -> h * hashKey + fromIntegral b) 0 + +hashKey :: Word32 +{-# INLINE hashKey #-} +hashKey = 2891336453 + +-- Precondition: Length of bytes is greater than or equal to 1. +-- Precondition: Rolling hash agrees with pattern. +-- Output: Negative one means match not found. Other negative +-- numbers should not occur. Zero should not occur. Positive number +-- means the number of bytes to skip to make it past the match. +karpRabin :: Word32 -> Bytes -> Bytes -> Int +karpRabin !hp !pat !src + | length src < lp = (-1) + | otherwise = search (rollingHash $ Pure.unsafeTake lp src) lp + where + lp :: Int + !lp = Pure.length pat + m :: Word32 + !m = hashKey ^ lp + get :: Int -> Word32 + get !ix = fromIntegral (Pure.unsafeIndex src ix) + search !hs !i + | hp == hs && eqBytesNoShortCut pat (Pure.unsafeTake lp (Pure.unsafeDrop (i - lp) src)) = i + | length src <= i = (-1) + | otherwise = search hs' (i + 1) + where + hs' = + hs * hashKey + + get i + - m * get (i - lp) + +{- | Is the first argument an infix of the second argument? + +Uses the Rabin-Karp algorithm: expected time @O(n+m)@, worst-case @O(nm)@. +-} +isInfixOf :: + -- | String to search for + Bytes -> + -- | String to search in + Bytes -> + Bool +isInfixOf p s = Pure.null p || breakSubstring p s >= 0 + +-- Precondition: both arguments have the same length +-- Skips the pointer equality check and the length check. +eqBytesNoShortCut :: Bytes -> Bytes -> Bool +{-# INLINE eqBytesNoShortCut #-} +eqBytesNoShortCut (Bytes arr1 off1 len1) (Bytes arr2 off2 _) = + PM.compareByteArrays arr1 off1 arr2 off2 len1 == EQ diff --git a/src/Data/Bytes/Text/Ascii.hs b/src/Data/Bytes/Text/Ascii.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Text/Ascii.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE TypeApplications #-} + +{- | This module treats 'Bytes' data as holding ASCII text. Providing bytes +outside the ASCII range (@U+0000@ -- @U+007F@) may cause a failure or +unspecified results, but such bytes will never be inspected. + +For functions that can operate on ASCII-compatible encodings, see +'Data.Bytes.Text.AsciiExt'. +-} +module Data.Bytes.Text.Ascii + ( fromString + , decodeDecWord + , equalsCStringCaseInsensitive + , toShortText + , toShortTextU +#if MIN_VERSION_text(2,0,0) + , toText +#endif + ) where + +import Data.Bits ((.&.)) +import Data.ByteString.Short.Internal (ShortByteString (SBS)) +import Data.Bytes.Text.Latin1 (decodeDecWord) +import Data.Bytes.Types (Bytes (Bytes)) +import Data.Char (ord) +import Data.Primitive (ByteArray) +import Data.Text (Text) +import Data.Text.Short (ShortText) +import Data.Word (Word8) +import Foreign.C.String (CString) +import Foreign.Ptr (Ptr, castPtr, plusPtr) + +import qualified Data.Bytes.Pure as Bytes +import qualified Data.Primitive as PM +import qualified Data.Primitive.Ptr as PM +import qualified Data.Text.Array as A +import qualified Data.Text.Internal as I +import qualified Data.Text.Short.Unsafe as TS +import qualified GHC.Exts as Exts + +{- | Convert a 'String' consisting of only characters in the ASCII block +to a byte sequence. Any character with a codepoint above @U+007F@ is +replaced by @U+0000@. +-} +fromString :: String -> Bytes +fromString = + Bytes.fromByteArray + . Exts.fromList + . map (\c -> let i = ord c in if i < 128 then fromIntegral @Int @Word8 i else 0) + +-- TODO presumably also fromText and fromShortText + +toShortText :: Bytes -> Maybe ShortText +{-# INLINE toShortText #-} +toShortText !b = case Bytes.foldr (\w acc -> w < 128 && acc) True b of + True -> Just (TS.fromShortByteStringUnsafe (Bytes.toShortByteString b)) + False -> Nothing + +toShortTextU :: ByteArray -> Maybe ShortText +{-# INLINE toShortTextU #-} +toShortTextU !b = case Bytes.foldr (\w acc -> w < 128 && acc) True (Bytes.fromByteArray b) of + True -> Just (TS.fromShortByteStringUnsafe (case b of PM.ByteArray x -> SBS x)) + False -> Nothing + +#if MIN_VERSION_text(2,0,0) +-- | Interpret byte sequence as ASCII codepoints. +-- Only available when building with @text-2.0@ and newer. +-- Returns 'Nothing' if any of the bytes are outside of the +-- range @0x00-0x7F@ +toText :: Bytes -> Maybe Text +{-# inline toText #-} +toText !b@(Bytes (PM.ByteArray arr) off len) = case Bytes.foldr (\w acc -> w < 128 && acc) True b of + True -> Just (I.Text (A.ByteArray arr) off len) + False -> Nothing +#endif + +{- | Is the byte sequence equal to the @NUL@-terminated C String? +The C string must be a constant. +-} +equalsCStringCaseInsensitive :: CString -> Bytes -> Bool +{-# INLINE equalsCStringCaseInsensitive #-} +equalsCStringCaseInsensitive !ptr0 (Bytes arr off0 len0) = go (castPtr ptr0 :: Ptr Word8) off0 len0 + where + go !ptr !off !len = case len of + 0 -> PM.indexOffPtr ptr 0 == (0 :: Word8) + _ -> case PM.indexOffPtr ptr 0 of + 0 -> False + c -> + (c .&. 0b1101_1111) == (PM.indexByteArray arr off .&. 0b1101_1111) + && go (plusPtr ptr 1) (off + 1) (len - 1) diff --git a/src/Data/Bytes/Text/AsciiExt.hs b/src/Data/Bytes/Text/AsciiExt.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Text/AsciiExt.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} + +-- For functions that can fail for bytes outside the ASCII range, see +-- 'Data.Bytes.Ascii'. For functions that can inspect bytes outside ASCII, see +-- any of the modules for ASCII-compatible encodings (e.g. 'Data.Bytes.Utf8', +-- 'Data.Bytes.Latin1', and so on). + +{- | This module contains functions which operate on supersets of 'Bytes' containing ASCII-encoded text. +That is, none of the functions here inspect bytes with a value greater than 127, and do not fail due to the presence of such bytes. +-} +module Data.Bytes.Text.AsciiExt + ( -- * Line-Oriented IO + hFoldLines + , hForLines_ + + -- ** Standard Handles + , forLines_ + , foldLines + + -- * Predicates + , anyEq + + -- * Filtering + , takeWhileNotEq + , dropWhileNotEq + , takeWhileEndNotEq + , dropWhileEndEq + + -- * Splitting + -- ** Fixed from Beginning + , split1 + , splitTetragram1 + , split2 + , split3 + , split4 + + -- * Text Manipulation + , toLowerU + ) where + +import Control.Monad.ST (ST) +import Control.Monad.ST.Run (runByteArrayST) +import Data.Bytes.Types (Bytes (..)) +import Data.Char (ord) +import Data.Primitive (ByteArray) +import Data.Word (Word8) +import System.IO (Handle, hIsEOF, stdin) + +import qualified Data.ByteString.Char8 as BC8 +import qualified Data.Bytes.Pure as Bytes +import qualified Data.Bytes.Byte as Byte +import qualified Data.Primitive as PM + +-- | `hForLines_` over `stdin` +forLines_ :: (Bytes -> IO a) -> IO () +{-# INLINEABLE forLines_ #-} +forLines_ = hForLines_ stdin + +-- | `hFoldLines` over `stdin` +foldLines :: a -> (a -> Bytes -> IO a) -> IO a +{-# INLINEABLE foldLines #-} +foldLines = hFoldLines stdin + +{- | Perform an action on each line of the input, discarding results. +To maintain a running state, see 'hFoldLines'. + +Lines are extracted with with 'BC8.hGetLine', which does not document its +detection algorithm. As of writing (bytestring v0.11.1.0), lines are +delimited by a single @\n@ character (UNIX-style, as all things should be). +-} +hForLines_ :: Handle -> (Bytes -> IO a) -> IO () +hForLines_ h body = loop + where + loop = + hIsEOF h >>= \case + False -> do + line <- Bytes.fromByteString <$> BC8.hGetLine h + _ <- body line + loop + True -> pure () + +{- | Perform an action on each line of the input, threading state through the computation. +If you do not need to keep a state, see `hForLines_`. + +Lines are extracted with with 'BC8.hGetLine', which does not document its +detection algorithm. As of writing (bytestring v0.11.1.0), lines are +delimited by a single @\n@ character (UNIX-style, as all things should be). +-} +hFoldLines :: Handle -> a -> (a -> Bytes -> IO a) -> IO a +hFoldLines h z body = loop z + where + loop !x = + hIsEOF h >>= \case + False -> do + line <- Bytes.fromByteString <$> BC8.hGetLine h + x' <- body x line + loop x' + True -> pure x + +{- | /O(n)/ Convert ASCII letters to lowercase. This adds @0x20@ to bytes in the +range @[0x41,0x5A]@ (@A-Z@ ⇒ @a-z@) and leaves all other bytes alone. +Unconditionally copies the bytes. +-} +toLowerU :: Bytes -> ByteArray +toLowerU (Bytes src off0 len0) = + runByteArrayST action + where + action :: forall s. ST s ByteArray + action = do + dst <- PM.newByteArray len0 + let go !off !ix !len = + if len == 0 + then pure () + else do + let w = PM.indexByteArray src off :: Word8 + w' = + if w >= 0x41 && w <= 0x5A + then w + 32 + else w + PM.writeByteArray dst ix w' + go (off + 1) (ix + 1) (len - 1) + go off0 0 len0 + PM.unsafeFreezeByteArray dst + +-- | Throws an exception the 'Char' argument is non-ascii. +split1 :: Char -> Bytes -> Maybe (Bytes, Bytes) +{-# INLINE split1 #-} +split1 !c !b + | c > '\DEL' = errorWithoutStackTrace "Data.Bytes.Text.AsciiExt.split1: argument not in ASCII range" + | otherwise = Byte.split1 (c2w c) b + +-- | Throws an exception the 'Char' argument is non-ascii. +split2 :: Char -> Bytes -> Maybe (Bytes, Bytes, Bytes) +{-# INLINE split2 #-} +split2 !c !b + | c > '\DEL' = errorWithoutStackTrace "Data.Bytes.Text.AsciiExt.split2: argument not in ASCII range" + | otherwise = Byte.split2 (c2w c) b + +-- | Throws an exception the 'Char' argument is non-ascii. +split3 :: Char -> Bytes -> Maybe (Bytes, Bytes, Bytes, Bytes) +{-# INLINE split3 #-} +split3 !c !b + | c > '\DEL' = errorWithoutStackTrace "Data.Bytes.Text.AsciiExt.split3: argument not in ASCII range" + | otherwise = Byte.split3 (c2w c) b + +-- | Throws an exception the 'Char' argument is non-ascii. +split4 :: Char -> Bytes -> Maybe (Bytes, Bytes, Bytes, Bytes, Bytes) +{-# INLINE split4 #-} +split4 !c !b + | c > '\DEL' = errorWithoutStackTrace "Data.Bytes.Text.AsciiExt.split4: argument not in ASCII range" + | otherwise = Byte.split4 (c2w c) b + +-- | Throws an exception if any of the 'Char' arguments are non-ascii. +splitTetragram1 :: Char -> Char -> Char -> Char -> Bytes -> Maybe (Bytes, Bytes) +{-# inline splitTetragram1 #-} +splitTetragram1 !c0 !c1 !c2 !c3 !b + | c0 > '\DEL' || c1 > '\DEL' || c2 > '\DEL' || c3 > '\DEL' = + errorWithoutStackTrace "Data.Bytes.Text.AsciiExt.splitTetragram1: one of the characters is not in ASCII range" + | otherwise = Bytes.splitTetragram1 (c2w c0) (c2w c1) (c2w c2) (c2w c3) b + +c2w :: Char -> Word8 +{-# inline c2w #-} +c2w !c = fromIntegral @Int @Word8 (ord c) + +-- | Throws an exception the 'Char' argument is non-ascii. +dropWhileNotEq :: Char -> Bytes -> Bytes +dropWhileNotEq !c !b + | c > '\DEL' = errorWithoutStackTrace "Data.Bytes.Text.AsciiExt.dropWhileNotEq: argument not in ASCII range" + | otherwise = + let !w = c2w c + in Bytes.unsafeDrop (Bytes.countWhile (/= w) b) b + +-- | Throws an exception the 'Char' argument is non-ascii. +takeWhileNotEq :: Char -> Bytes -> Bytes +takeWhileNotEq !c !b + | c > '\DEL' = errorWithoutStackTrace "Data.Bytes.Text.AsciiExt.takeWhileNotEq: argument not in ASCII range" + | otherwise = + let !w = c2w c + in Bytes.unsafeTake (Bytes.countWhile (/= w) b) b + +-- | Throws an exception the 'Char' argument is non-ascii. +takeWhileEndNotEq :: Char -> Bytes -> Bytes +takeWhileEndNotEq !c !b + | c > '\DEL' = errorWithoutStackTrace "Data.Bytes.Text.AsciiExt.takeWhileEndNotEq: argument not in ASCII range" + | otherwise = + let !w = c2w c + !n = Bytes.countWhileEnd (/=w) b + in Bytes (array b) (offset b + Bytes.length b - n) n + +-- | Throws an exception the 'Char' argument is non-ascii. +dropWhileEndEq :: Char -> Bytes -> Bytes +dropWhileEndEq !c !b + | c > '\DEL' = errorWithoutStackTrace "Data.Bytes.Text.AsciiExt.dropWhileEndEq: argument not in ASCII range" + | otherwise = + let !w = c2w c + !n = Bytes.countWhileEnd (==w) b + in Bytes.unsafeTake (Bytes.length b - n) b + +-- | Throws an exception the 'Char' argument is non-ascii. +anyEq :: Char -> Bytes -> Bool +anyEq !c !b + | c > '\DEL' = errorWithoutStackTrace "Data.Bytes.Text.AsciiExt.takeWhileNotEq: argument not in ASCII range" + | otherwise = + let !w = c2w c + in Bytes.any (==w) b diff --git a/src/Data/Bytes/Text/Latin1.hs b/src/Data/Bytes/Text/Latin1.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Text/Latin1.hs @@ -0,0 +1,363 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedTuples #-} + +{- | This module treats 'Bytes' data as holding text encoded in ISO-8859-1. This +encoding can only encode codepoints strictly below @U+0100@, but this allows +each codepoint to be placed directly into a single byte. This range consists +of Unicode Basic Latin, Latin-1 Supplement and C0+C1 Controls, which includes +ASCII. + +Strictly, ISO-8859-1 is not to be confused with ISO/IEC 8859-1 (which was the +default encoding for webpages before HTML5). ISO/IEC 8859-1 lacks encodings +for the C0 and C1 control characters. + +With HTML5, the default encoding of webpages was changed to Windows-1252, +which is _not_ compatible with ISO-8859-1. Windows-1252 uses the C1 Control +range (@U+0080@ -- @U+009F@) mostly to encode a variety of printable +characters. For this encoding, see 'Data.Bytes.Text.Windows1252'. +-} +module Data.Bytes.Text.Latin1 + ( toString + , fromString + , decodeDecWord + + -- * Specialized Comparisons + , equals1 + , equals2 + , equals3 + , equals4 + , equals5 + , equals6 + , equals7 + , equals8 + , equals9 + , equals10 + , equals11 + , equals12 + , equals13 + , equals14 + , equals15 + ) where + +import Prelude hiding (length) + +import Data.Bytes.Types (Bytes (..)) +import Data.Char (chr, ord) +import Data.Primitive (ByteArray (ByteArray)) +import Data.Word (Word8) +import GHC.Exts (Char (C#), Int (I#), Word (W#), Word#, int2Word#, ltWord#, or#) + +import qualified Data.Bytes.Pure as Bytes +import qualified Data.Primitive as PM +import qualified GHC.Exts as Exts + +{- | Convert a 'String' consisting of only characters representable +by ISO-8859-1. These are encoded with ISO-8859-1. Any character +with a codepoint above @U+00FF@ is replaced by an unspecified byte. +-} +fromString :: String -> Bytes +fromString = + Bytes.fromByteArray . Exts.fromList . map (fromIntegral @Int @Word8 . ord) + +-- | Interpret a byte sequence as text encoded by ISO-8859-1. +toString :: Bytes -> String +{-# INLINE toString #-} +toString = Bytes.foldr (\w xs -> chr (fromIntegral @Word8 @Int w) : xs) [] + +-- TODO presumably also fromText and fromShortText + +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a singleton whose element matches the character? +-} +equals1 :: Char -> Bytes -> Bool +{-# INLINE equals1 #-} +equals1 !c0 (Bytes arr off len) = case len of + 1 -> c0 == indexCharArray arr off + _ -> False + +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a doubleton whose elements match the characters? +-} +equals2 :: Char -> Char -> Bytes -> Bool +equals2 !c0 !c1 (Bytes arr off len) = case len of + 2 -> + c0 == indexCharArray arr off + && c1 == indexCharArray arr (off + 1) + _ -> False + +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a tripleton whose elements match the characters? +-} +equals3 :: Char -> Char -> Char -> Bytes -> Bool +equals3 !c0 !c1 !c2 (Bytes arr off len) = case len of + 3 -> + c0 == indexCharArray arr off + && c1 == indexCharArray arr (off + 1) + && c2 == indexCharArray arr (off + 2) + _ -> False + +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a quadrupleton whose elements match the characters? +-} +equals4 :: Char -> Char -> Char -> Char -> Bytes -> Bool +equals4 !c0 !c1 !c2 !c3 (Bytes arr off len) = case len of + 4 -> + c0 == indexCharArray arr off + && c1 == indexCharArray arr (off + 1) + && c2 == indexCharArray arr (off + 2) + && c3 == indexCharArray arr (off + 3) + _ -> False + +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a quintupleton whose elements match the characters? +-} +equals5 :: Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +equals5 !c0 !c1 !c2 !c3 !c4 (Bytes arr off len) = case len of + 5 -> + c0 == indexCharArray arr off + && c1 == indexCharArray arr (off + 1) + && c2 == indexCharArray arr (off + 2) + && c3 == indexCharArray arr (off + 3) + && c4 == indexCharArray arr (off + 4) + _ -> False + +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a sextupleton whose elements match the characters? +-} +equals6 :: Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +equals6 !c0 !c1 !c2 !c3 !c4 !c5 (Bytes arr off len) = case len of + 6 -> + c0 == indexCharArray arr off + && c1 == indexCharArray arr (off + 1) + && c2 == indexCharArray arr (off + 2) + && c3 == indexCharArray arr (off + 3) + && c4 == indexCharArray arr (off + 4) + && c5 == indexCharArray arr (off + 5) + _ -> False + +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a septupleton whose elements match the characters? +-} +equals7 :: Char -> Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +equals7 !c0 !c1 !c2 !c3 !c4 !c5 !c6 (Bytes arr off len) = case len of + 7 -> + c0 == indexCharArray arr off + && c1 == indexCharArray arr (off + 1) + && c2 == indexCharArray arr (off + 2) + && c3 == indexCharArray arr (off + 3) + && c4 == indexCharArray arr (off + 4) + && c5 == indexCharArray arr (off + 5) + && c6 == indexCharArray arr (off + 6) + _ -> False + +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +an octupleton whose elements match the characters? +-} +equals8 :: Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +equals8 !c0 !c1 !c2 !c3 !c4 !c5 !c6 !c7 (Bytes arr off len) = case len of + 8 -> + c0 == indexCharArray arr off + && c1 == indexCharArray arr (off + 1) + && c2 == indexCharArray arr (off + 2) + && c3 == indexCharArray arr (off + 3) + && c4 == indexCharArray arr (off + 4) + && c5 == indexCharArray arr (off + 5) + && c6 == indexCharArray arr (off + 6) + && c7 == indexCharArray arr (off + 7) + _ -> False + +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a 9-tuple whose elements match the characters? +-} +equals9 :: Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +equals9 !c0 !c1 !c2 !c3 !c4 !c5 !c6 !c7 !c8 (Bytes arr off len) = case len of + 9 -> + c0 == indexCharArray arr off + && c1 == indexCharArray arr (off + 1) + && c2 == indexCharArray arr (off + 2) + && c3 == indexCharArray arr (off + 3) + && c4 == indexCharArray arr (off + 4) + && c5 == indexCharArray arr (off + 5) + && c6 == indexCharArray arr (off + 6) + && c7 == indexCharArray arr (off + 7) + && c8 == indexCharArray arr (off + 8) + _ -> False + +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a 10-tuple whose elements match the characters? +-} +equals10 :: Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +equals10 !c0 !c1 !c2 !c3 !c4 !c5 !c6 !c7 !c8 !c9 (Bytes arr off len) = case len of + 10 -> + c0 == indexCharArray arr off + && c1 == indexCharArray arr (off + 1) + && c2 == indexCharArray arr (off + 2) + && c3 == indexCharArray arr (off + 3) + && c4 == indexCharArray arr (off + 4) + && c5 == indexCharArray arr (off + 5) + && c6 == indexCharArray arr (off + 6) + && c7 == indexCharArray arr (off + 7) + && c8 == indexCharArray arr (off + 8) + && c9 == indexCharArray arr (off + 9) + _ -> False + +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a 11-tuple whose elements match the characters? +-} +equals11 :: Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +equals11 !c0 !c1 !c2 !c3 !c4 !c5 !c6 !c7 !c8 !c9 !c10 (Bytes arr off len) = case len of + 11 -> + c0 == indexCharArray arr off + && c1 == indexCharArray arr (off + 1) + && c2 == indexCharArray arr (off + 2) + && c3 == indexCharArray arr (off + 3) + && c4 == indexCharArray arr (off + 4) + && c5 == indexCharArray arr (off + 5) + && c6 == indexCharArray arr (off + 6) + && c7 == indexCharArray arr (off + 7) + && c8 == indexCharArray arr (off + 8) + && c9 == indexCharArray arr (off + 9) + && c10 == indexCharArray arr (off + 10) + _ -> False + +{- | Is the byte sequence, when interpreted as ISO-8859-1-encoded text, +a 12-tuple whose elements match the characters? +-} +equals12 :: Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +equals12 !c0 !c1 !c2 !c3 !c4 !c5 !c6 !c7 !c8 !c9 !c10 !c11 (Bytes arr off len) = case len of + 12 -> + c0 == indexCharArray arr off + && c1 == indexCharArray arr (off + 1) + && c2 == indexCharArray arr (off + 2) + && c3 == indexCharArray arr (off + 3) + && c4 == indexCharArray arr (off + 4) + && c5 == indexCharArray arr (off + 5) + && c6 == indexCharArray arr (off + 6) + && c7 == indexCharArray arr (off + 7) + && c8 == indexCharArray arr (off + 8) + && c9 == indexCharArray arr (off + 9) + && c10 == indexCharArray arr (off + 10) + && c11 == indexCharArray arr (off + 11) + _ -> False + +equals13 :: Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +equals13 !c0 !c1 !c2 !c3 !c4 !c5 !c6 !c7 !c8 !c9 !c10 !c11 !c12 (Bytes arr off len) = case len of + 13 -> + c0 == indexCharArray arr off + && c1 == indexCharArray arr (off + 1) + && c2 == indexCharArray arr (off + 2) + && c3 == indexCharArray arr (off + 3) + && c4 == indexCharArray arr (off + 4) + && c5 == indexCharArray arr (off + 5) + && c6 == indexCharArray arr (off + 6) + && c7 == indexCharArray arr (off + 7) + && c8 == indexCharArray arr (off + 8) + && c9 == indexCharArray arr (off + 9) + && c10 == indexCharArray arr (off + 10) + && c11 == indexCharArray arr (off + 11) + && c12 == indexCharArray arr (off + 12) + _ -> False + +equals14 :: Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +equals14 !c0 !c1 !c2 !c3 !c4 !c5 !c6 !c7 !c8 !c9 !c10 !c11 !c12 !c13 (Bytes arr off len) = case len of + 14 -> + c0 == indexCharArray arr off + && c1 == indexCharArray arr (off + 1) + && c2 == indexCharArray arr (off + 2) + && c3 == indexCharArray arr (off + 3) + && c4 == indexCharArray arr (off + 4) + && c5 == indexCharArray arr (off + 5) + && c6 == indexCharArray arr (off + 6) + && c7 == indexCharArray arr (off + 7) + && c8 == indexCharArray arr (off + 8) + && c9 == indexCharArray arr (off + 9) + && c10 == indexCharArray arr (off + 10) + && c11 == indexCharArray arr (off + 11) + && c12 == indexCharArray arr (off + 12) + && c13 == indexCharArray arr (off + 13) + _ -> False + +equals15 :: Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> Bytes -> Bool +equals15 !c0 !c1 !c2 !c3 !c4 !c5 !c6 !c7 !c8 !c9 !c10 !c11 !c12 !c13 !c14 (Bytes arr off len) = case len of + 15 -> + c0 == indexCharArray arr off + && c1 == indexCharArray arr (off + 1) + && c2 == indexCharArray arr (off + 2) + && c3 == indexCharArray arr (off + 3) + && c4 == indexCharArray arr (off + 4) + && c5 == indexCharArray arr (off + 5) + && c6 == indexCharArray arr (off + 6) + && c7 == indexCharArray arr (off + 7) + && c8 == indexCharArray arr (off + 8) + && c9 == indexCharArray arr (off + 9) + && c10 == indexCharArray arr (off + 10) + && c11 == indexCharArray arr (off + 11) + && c12 == indexCharArray arr (off + 12) + && c13 == indexCharArray arr (off + 13) + && c14 == indexCharArray arr (off + 14) + _ -> False + +indexCharArray :: ByteArray -> Int -> Char +indexCharArray (ByteArray arr) (I# off) = C# (Exts.indexCharArray# arr off) + +{- | Decode machine-sized word from decimal representation. Returns +Nothing on overflow. Allows any number of leading zeros. Trailing +non-digit bytes cause Nothing to be returned. +-} +decodeDecWord :: Bytes -> Maybe Word +{-# INLINE decodeDecWord #-} +decodeDecWord !b = case decWordStart b of + (# (# #) | #) -> Nothing + (# | w #) -> Just (W# w) + +decWordStart :: + Bytes -> -- Chunk + (# (# #) | Word# #) +{-# NOINLINE decWordStart #-} +decWordStart !chunk0 = + if length chunk0 > 0 + then + let !w = + fromIntegral @Word8 @Word + (PM.indexByteArray (array chunk0) (offset chunk0)) + - 48 + in if w < 10 + then decWordMore w (Bytes.unsafeDrop 1 chunk0) + else (# (# #) | #) + else (# (# #) | #) + where + decWordMore :: + Word -> -- Accumulator + Bytes -> -- Chunk + (# (# #) | Word# #) + decWordMore !acc !chunk = + let len = length chunk + in case len of + 0 -> (# | unW (fromIntegral acc) #) + _ -> + let !w = + fromIntegral @Word8 @Word + (PM.indexByteArray (array chunk) (offset chunk)) + - 48 + in if w < 10 + then + let (overflow, acc') = unsignedPushBase10 acc w + in if overflow + then (# (# #) | #) + else decWordMore acc' (Bytes.unsafeDrop 1 chunk) + else (# (# #) | #) + +unsignedPushBase10 :: Word -> Word -> (Bool, Word) +{-# INLINE unsignedPushBase10 #-} +unsignedPushBase10 (W# a) (W# b) = + let !(# ca, r0 #) = Exts.timesWord2# a 10## + !r1 = Exts.plusWord# r0 b + !cb = int2Word# (ltWord# r1 r0) + !c = ca `or#` cb + in (case c of 0## -> False; _ -> True, W# r1) + +unW :: Word -> Word# +{-# INLINE unW #-} +unW (W# w) = w diff --git a/src/Data/Bytes/Text/Utf8.hs b/src/Data/Bytes/Text/Utf8.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Text/Utf8.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +-- | Convert 'Bytes' to and from 'Text' and 'ShortText'. +module Data.Bytes.Text.Utf8 + ( fromShortText + , toShortText +#if MIN_VERSION_text(2,0,0) + , fromText +#endif +#if MIN_VERSION_text(2,1,0) + , toText +#endif + ) where + +import Data.Bytes.Types (Bytes (Bytes)) +import Data.Primitive (ByteArray (ByteArray)) +import Data.Text (Text) +import Data.Text.Short (ShortText) + +import qualified Data.Bytes as Bytes +import qualified Data.Text.Array as A +import qualified Data.Text.Internal as I +import qualified Data.Text.Short as TS + +#if MIN_VERSION_text(2,1,0) +import qualified Data.Text.Internal.Validate +#endif + +{- | Encode 'ShortText' using UTF-8. Since 'ShortText' is backed by a UTF-8 +byte sequence, this does not perform a copy. +-} +fromShortText :: ShortText -> Bytes +{-# INLINE fromShortText #-} +fromShortText = Bytes.fromShortByteString . TS.toShortByteString + +{- | Attempt to interpret the byte sequence as UTF-8 encoded text. Returns +'Nothing' if the bytes are not UTF-8 encoded text. +-} +toShortText :: Bytes -> Maybe ShortText +{-# INLINE toShortText #-} +toShortText !b = TS.fromShortByteString (Bytes.toShortByteString b) + +#if MIN_VERSION_text(2,0,0) +-- | Encode 'Text' using @UTF-8@. Only available when building with +-- @text-2.0@ and newer. Since 'Text' is backed by a UTF-8 +-- byte sequence, this does not perform a copy. +fromText :: Text -> Bytes +{-# inline fromText #-} +fromText (I.Text (A.ByteArray b) off len) = Bytes (ByteArray b) off len +#endif + +#if MIN_VERSION_text(2,1,0) +-- | Attempt to interpret byte sequence as @UTF-8@ encoded 'Text'. +-- Only available when building with @text-2.1@ and newer. Since +-- 'Text' is backed by a UTF-8 byte sequence, this does not perform a +-- copy. +toText :: Bytes -> Maybe Text +{-# inline toText #-} +toText (Bytes b@(ByteArray b0) off len) = + if Data.Text.Internal.Validate.isValidUtf8ByteArray b off len + then Just (I.Text (A.ByteArray b0) off len) + else Nothing +#endif diff --git a/src/Data/Bytes/Text/Windows1252.hs b/src/Data/Bytes/Text/Windows1252.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Text/Windows1252.hs @@ -0,0 +1,4 @@ +{- | Placeholder module in case there is demand for treating 'Bytes' as +Windows-1252-encoded text +-} +module Data.Bytes.Text.Windows1252 () where diff --git a/src/Data/Bytes/Types.hs b/src/Data/Bytes/Types.hs --- a/src/Data/Bytes/Types.hs +++ b/src/Data/Bytes/Types.hs @@ -1,34 +1,55 @@ -{-# language BangPatterns #-} -{-# language MagicHash #-} -{-# language TypeFamilies #-} -{-# language DuplicateRecordFields #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Data.Bytes.Types - ( Bytes(..) - , MutableBytes(..) - , UnmanagedBytes(..) + ( Bytes (..) + , Bytes# (..) + , MutableBytes (..) + , UnmanagedBytes (..) + , BytesN (..) + , ByteArrayN (..) ) where -import Control.Monad.ST (runST) -import Data.Primitive (ByteArray(..),MutableByteArray(..)) +import Data.Bytes.Internal (Bytes (..)) +import Data.Bytes.Internal.Show (showsSlice) +import Data.Primitive (ByteArray (..), MutableByteArray (..)) import Data.Primitive.Addr (Addr) -import Data.Bits ((.&.),unsafeShiftR) -import Data.Char (ord) -import Data.Word (Word8) -import GHC.Base (unsafeChr) -import GHC.Exts (Int(I#),unsafeCoerce#,sameMutableByteArray#) -import GHC.Exts (isTrue#,compareByteArrays#,IsList(..)) - -import qualified Data.List as L -import qualified Data.Primitive as PM +import Data.Proxy (Proxy (Proxy)) +import GHC.Natural (naturalToInteger) +import GHC.TypeNats (KnownNat, Nat, natVal) +import Reps (Bytes# (..)) --- | A slice of a 'ByteArray'. -data Bytes = Bytes +{- | A slice of a 'ByteArray' whose compile-time-known length is represented +by a phantom type variable. Consumers of this data constructor must be +careful to preserve the expected invariant. +-} +data BytesN (n :: Nat) = BytesN { array :: {-# UNPACK #-} !ByteArray , offset :: {-# UNPACK #-} !Int - , length :: {-# UNPACK #-} !Int } +instance (KnownNat n) => Show (BytesN n) where + showsPrec _ (BytesN arr off) s = + let len = fromInteger (naturalToInteger (natVal (Proxy :: Proxy n))) + in showsSlice arr off len s + +{- | A 'ByteArray' whose compile-time-known length is represented +by a phantom type variable. Consumers of this data constructor must be +careful to preserve the expected invariant. +-} +newtype ByteArrayN (n :: Nat) = ByteArrayN + { array :: ByteArray + } + +instance (KnownNat n) => Show (ByteArrayN n) where + showsPrec _ (ByteArrayN arr) s = + let len = fromInteger (naturalToInteger (natVal (Proxy :: Proxy n))) + in showsSlice arr 0 len s + -- | A slice of a 'MutableByteArray'. data MutableBytes s = MutableBytes { array :: {-# UNPACK #-} !(MutableByteArray s) @@ -41,67 +62,3 @@ { address :: {-# UNPACK #-} !Addr , length :: {-# UNPACK #-} !Int } - -instance IsList Bytes where - type Item Bytes = Word8 - fromListN n xs = Bytes (fromListN n xs) 0 n - fromList xs = fromListN (L.length xs) xs - toList (Bytes arr off len) = toListLoop off len arr - -toListLoop :: Int -> Int -> ByteArray -> [Word8] -toListLoop !off !len !arr = if len > 0 - then PM.indexByteArray arr off : toListLoop (off + 1) (len - 1) arr - else [] - -instance Show Bytes where - showsPrec _ (Bytes arr off len) s = if len == 0 - then showString "[]" s - else showString "[0x" - $ showHexDigits (PM.indexByteArray arr off) - $ showLoop (off + 1) (len - 1) arr - $ showChar ']' - $ s - -showLoop :: Int -> Int -> ByteArray -> String -> String -showLoop !ix !len !arr s = if len > 0 - then ',':'0':'x':showHexDigits (PM.indexByteArray arr ix) (showLoop (ix + 1) (len - 1) arr s) - else s - -showHexDigits :: Word8 -> String -> String -showHexDigits !w s = word4ToChar (unsafeShiftR w 4) : word4ToChar (0x0F .&. w) : s - -word4ToChar :: Word8 -> Char -word4ToChar w = if w < 10 - then unsafeChr (ord '0' + fromIntegral w) - else unsafeChr (ord 'a' + (fromIntegral w) - 10) - -instance Eq Bytes where - Bytes arr1 off1 len1 == Bytes arr2 off2 len2 - | len1 /= len2 = False - | sameByteArray arr1 arr2 && off1 == off2 = True - | otherwise = compareByteArrays arr1 off1 arr2 off2 len1 == EQ - -instance Ord Bytes where - compare (Bytes arr1 off1 len1) (Bytes arr2 off2 len2) - | sameByteArray arr1 arr2 && off1 == off2 && len1 == len2 = EQ - | otherwise = compareByteArrays arr1 off1 arr2 off2 len1 - -instance Semigroup Bytes where - -- TODO: Do the trick to move the data constructor to the outside - -- of runST. - Bytes arrA offA lenA <> Bytes arrB offB lenB = runST $ do - marr <- PM.newByteArray (lenA + lenB) - PM.copyByteArray marr 0 arrA offA lenA - PM.copyByteArray marr lenA arrB offB lenB - r <- PM.unsafeFreezeByteArray marr - pure (Bytes r 0 (lenA + lenB)) - -compareByteArrays :: ByteArray -> Int -> ByteArray -> Int -> Int -> Ordering -{-# INLINE compareByteArrays #-} -compareByteArrays (ByteArray ba1#) (I# off1#) (ByteArray ba2#) (I# off2#) (I# n#) = - compare (I# (compareByteArrays# ba1# off1# ba2# off2# n#)) 0 - -sameByteArray :: ByteArray -> ByteArray -> Bool -{-# INLINE sameByteArray #-} -sameByteArray (ByteArray ba1#) (ByteArray ba2#) = - isTrue# (sameMutableByteArray# (unsafeCoerce# ba1#) (unsafeCoerce# ba2#)) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,124 +1,339 @@ -{-# language BangPatterns #-} -{-# language MultiWayIf #-} -{-# language NumDecimals #-} -{-# language OverloadedStrings #-} -{-# language ScopedTypeVariables #-} -{-# language TypeApplications #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +import Control.Monad.Trans.Writer (Writer, tell) +import Data.Bytes.Chunks (Chunks (ChunksCons, ChunksNil)) +import Data.Bytes.Types (Bytes (Bytes)) +import Data.Char (ord) import Data.Primitive (ByteArray) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) import Data.Word (Word8) -import Data.Char (ord) -import Data.Bytes.Types (Bytes(Bytes)) -import Test.Tasty (defaultMain,testGroup,TestTree) -import Test.Tasty.HUnit ((@=?),testCase) -import Test.Tasty.QuickCheck ((===),testProperty,property,Discard(Discard)) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (testCase, (@=?)) +import Test.Tasty.QuickCheck + ( ASCIIString (ASCIIString) + , Arbitrary + , Discard (Discard) + , property + , testProperty + , (===) + , (==>) + ) -import qualified Data.Bytes as Bytes import qualified Data.ByteString as ByteString +import qualified Data.Bytes as Bytes +import qualified Data.Bytes.Chunks as Chunks +import qualified Data.Bytes.Text.Ascii as Ascii +import qualified Data.Bytes.Text.AsciiExt as AsciiExt +import qualified Data.Bytes.Text.Latin1 as Latin1 import qualified Data.Foldable as Foldable import qualified Data.List as List import qualified Data.Primitive as PM +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding import qualified GHC.Exts as Exts +import qualified Test.QuickCheck.Classes as QCC import qualified Test.Tasty.HUnit as THU +import qualified Test.Tasty.QuickCheck as TQC main :: IO () main = defaultMain tests tests :: TestTree -tests = testGroup "Bytes" - [ testGroup "isPrefixOf" - [ testCase "A" $ THU.assertBool "" $ - Bytes.isPrefixOf (bytes "hey") (bytes "hey man") - , testCase "B" $ THU.assertBool "" $ - not (Bytes.isPrefixOf (bytes "an") (bytes "hey man")) - ] - , testGroup "isSuffixOf" - [ testCase "A" $ THU.assertBool "" $ - Bytes.isSuffixOf (bytes "an") (bytes "hey man") - , testCase "B" $ THU.assertBool "" $ - not (Bytes.isSuffixOf (bytes "h") (bytes "hey man")) - ] - , testGroup "stripOptionalSuffix" - [ testCase "A" $ - Bytes.fromAsciiString "hey m" - @=? - Bytes.stripOptionalSuffix (bytes "an") (bytes "hey man") - , testCase "B" $ - Bytes.fromAsciiString "hey man" - @=? - Bytes.stripOptionalSuffix (bytes "h") (bytes "hey man") - ] - , testGroup "dropWhileEnd" - [ testCase "A" $ - Bytes.fromAsciiString "aabbcc" - @=? - Bytes.dropWhileEnd (== c2w 'b') (bytes "aabbccbb") - ] - , testGroup "takeWhileEnd" - [ testCase "A" $ - Bytes.fromAsciiString "bb" - @=? - Bytes.takeWhileEnd (== c2w 'b') (bytes "aabbccbb") - , testCase "B" $ - Bytes.fromAsciiString "" - @=? - Bytes.takeWhileEnd (/= c2w '\n') (bytes "aabbccbb\n") - , testCase "C" $ - slicedPack [0x1,0x2,0x3] - @=? - Bytes.takeWhileEnd (/= 0x0) (slicedPack [0x1,0x0,0x1,0x2,0x3]) +tests = + testGroup + "Bytes" + [ lawsToTest (QCC.eqLaws (Proxy :: Proxy Bytes)) + , lawsToTest (QCC.ordLaws (Proxy :: Proxy Bytes)) + , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy Bytes)) + , lawsToTest (QCC.monoidLaws (Proxy :: Proxy Bytes)) + , testGroup + "toLowerAsciiByteArrayClone" + [ testCase "A" $ + THU.assertBool "" $ + Bytes.isPrefixOf (bytes "hey") (bytes "hey man") + ] + , testGroup + "isPrefixOf" + [ testCase "A" $ + AsciiExt.toLowerU (bytes "FooBar") + @=? pack "foobar" + , testCase "B" $ + THU.assertBool "" $ + not (Bytes.isPrefixOf (bytes "an") (bytes "hey man")) + ] + , testGroup + "isSuffixOf" + [ testCase "A" $ + THU.assertBool "" $ + Bytes.isSuffixOf (bytes "an") (bytes "hey man") + , testCase "B" $ + THU.assertBool "" $ + not (Bytes.isSuffixOf (bytes "h") (bytes "hey man")) + ] + , testGroup + "isInfixOf" + [ testCase "small pattern A" $ + THU.assertBool "" $ + Bytes.isInfixOf (bytes "y m") (bytes "hey man") + , testCase "small pattern B" $ + THU.assertBool "" $ + Bytes.isInfixOf (bytes "h") (bytes "hey man") + , testCase "small pattern C" $ + THU.assertBool "" $ + Bytes.isInfixOf (bytes "an") (bytes "hey man") + , testCase "small pattern D" $ + THU.assertBool "" $ + not (Bytes.isInfixOf (bytes "Y M") (bytes "hey man")) + , testCase "large pattern A" $ + THU.assertBool "" $ + Bytes.isInfixOf (bytes "Hello, hello!") (bytes "I say hello. Hello, hello! I don't know why you say goodbye, I say hello!") + , testCase "large pattern D" $ + THU.assertBool "" $ + not (Bytes.isInfixOf (bytes "Hello, hello!") (bytes "I don't know why you say goodbye, I say hello!")) + , testCase "edge: empty pattern" $ + THU.assertBool "" $ + Bytes.isInfixOf (bytes "") (bytes "hello hello!") + , testCase "edge: empty string" $ + THU.assertBool "" $ + not (Bytes.isInfixOf (bytes "hello hello!") (bytes "")) + ] + , testGroup + "findIndices" + [ testCase "A" $ + Exts.fromList [4] + @=? Bytes.findIndices (Bytes.fromByteArray (pack "greatest showman")) (Bytes.fromByteArray (pack "the greatest showman of all")) + , testCase "B" $ + Exts.fromList [4] + @=? Bytes.findIndices (bytes "greatest showman") (bytes "the greatest showman of all") + , testCase "C" $ + Exts.fromList [0, 1, 2, 3, 4, 5] + @=? Bytes.findIndices (bytes "a") (bytes "aaaaaa") + , testCase "D" $ + Exts.fromList [0, 2, 4] + @=? Bytes.findIndices (bytes "aa") (bytes "aaaaaaa") + ] + , testGroup + "replace-spec" + [ testCase "A" $ + Bytes.empty + @=? Bytes.replace (Bytes.fromByteArray (pack "hello")) (Bytes.fromByteArray (pack "world")) Bytes.empty + , testCase "B" $ + bytes "xzybbcbbc" + @=? Bytes.replace (bytes "a") (bytes "b") (bytes "xzyabcabc") + , testCase "C" $ + bytes "my favorite month is March!" + @=? Bytes.replace (bytes "November") (bytes "March") (bytes "my favorite month is November!") + , testCase "D" $ + bytes "Saturn, Saturn, Mars, Saturn" + @=? Bytes.replace (bytes "Jupiter") (bytes "Saturn") (bytes "Jupiter, Jupiter, Mars, Jupiter") + ] + , testGroup + "stripOptionalSuffix" + [ testCase "A" $ + Ascii.fromString "hey m" + @=? Bytes.stripOptionalSuffix (bytes "an") (bytes "hey man") + , testCase "B" $ + Ascii.fromString "hey man" + @=? Bytes.stripOptionalSuffix (bytes "h") (bytes "hey man") + ] + , testGroup + "longestCommonPrefix" + [ testProperty "finds prefix" $ \(pre :: Bytes) (a :: Bytes) (b :: Bytes) -> + if + | Just (wa, _) <- Bytes.uncons a + , Just (wb, _) <- Bytes.uncons b + , wa /= wb -> + Bytes.longestCommonPrefix (pre <> a) (pre <> b) === pre + | otherwise -> property Discard + , testProperty "finds no prefix" $ \(a :: Bytes) (b :: Bytes) -> + if + | Just (wa, _) <- Bytes.uncons a + , Just (wb, _) <- Bytes.uncons b + , wa /= wb -> + Bytes.longestCommonPrefix a b === mempty + | otherwise -> property Discard + ] + , testGroup + "dropWhileEnd" + [ testCase "A" $ + Ascii.fromString "aabbcc" + @=? Bytes.dropWhileEnd (== c2w 'b') (bytes "aabbccbb") + ] + , testGroup + "takeWhileEnd" + [ testCase "A" $ + Ascii.fromString "bb" + @=? Bytes.takeWhileEnd (== c2w 'b') (bytes "aabbccbb") + , testCase "B" $ + Ascii.fromString "" + @=? Bytes.takeWhileEnd (/= c2w '\n') (bytes "aabbccbb\n") + , testCase "C" $ + slicedPack [0x1, 0x2, 0x3] + @=? Bytes.takeWhileEnd (/= 0x0) (slicedPack [0x1, 0x0, 0x1, 0x2, 0x3]) + ] + , testProperty "decodeDecWord" $ \(w :: Word) -> + Just w + === Latin1.decodeDecWord (Bytes.unsafeDrop 1 (Exts.fromList (0xFF : (Exts.toList (Latin1.fromString (show w)))))) + , testProperty "elem" $ \(x :: Word8) (xs :: [Word8]) -> + List.elem x xs + === Bytes.elem x (Bytes.unsafeDrop 1 (Exts.fromList (x : xs))) + , testProperty "foldl" $ \(x :: Word8) (xs :: [Word8]) -> + List.foldl (-) 0 xs + === Bytes.foldl (-) 0 (Bytes.unsafeDrop 1 (Exts.fromList (x : xs))) + , testProperty "foldlM" $ \(x :: Word8) (xs :: [Word8]) -> + let f acc y = (tell [x] >> pure (acc - y)) :: Writer [Word8] Word8 + in Foldable.foldlM f 0 xs + === Bytes.foldlM f 0 (Bytes.unsafeDrop 1 (Exts.fromList (x : xs))) + , testProperty "foldrM" $ \(x :: Word8) (xs :: [Word8]) -> + let f acc y = (tell [x] >> pure (acc - y)) :: Writer [Word8] Word8 + in Foldable.foldrM f 0 xs + === Bytes.foldrM f 0 (Bytes.unsafeDrop 1 (Exts.fromList (x : xs))) + , testProperty "foldl'" $ \(x :: Word8) (xs :: [Word8]) -> + List.foldl' (-) 0 xs + === Bytes.foldl' (-) 0 (Bytes.unsafeDrop 1 (Exts.fromList (x : xs))) + , testProperty "foldr" $ \(x :: Word8) (xs :: [Word8]) -> + Foldable.foldr (-) 0 xs + === Bytes.foldr (-) 0 (Bytes.unsafeDrop 1 (Exts.fromList (x : xs))) + , testProperty "foldr'" $ \(x :: Word8) (xs :: [Word8]) -> + Foldable.foldr' (-) 0 xs + === Bytes.foldr' (-) 0 (Bytes.unsafeDrop 1 (Exts.fromList (x : xs))) + , testProperty "count" $ \(x :: Word8) (xs :: [Word8]) -> + ByteString.count x (ByteString.pack xs) + === Bytes.count x (slicedPack xs) + , testProperty "split" $ \(x :: Word8) (xs :: [Word8]) -> + not (List.null xs) + ==> ByteString.split x (ByteString.pack xs) + === map bytesToByteString (Bytes.split x (slicedPack xs)) + , testProperty "intercalate" $ \(x :: Bytes) (xs :: [Bytes]) -> + mconcat (List.intersperse x xs) + === Bytes.intercalate x xs + , testProperty "concatArray" $ \(xs :: [Bytes]) -> + mconcat xs + === Bytes.concatArray (Exts.fromList xs) + , testProperty "splitNonEmpty" $ \(x :: Word8) (xs :: [Word8]) -> + Bytes.split x (slicedPack xs) + === Foldable.toList (Bytes.splitNonEmpty x (slicedPack xs)) + , testProperty "splitInit" $ \(x :: Word8) (xs :: [Word8]) -> case xs of + [] -> Bytes.splitInit x (slicedPack xs) === [] + _ -> + List.init (ByteString.split x (ByteString.pack xs)) + === map bytesToByteString (Bytes.splitInit x (slicedPack xs)) + , testProperty "splitU" $ \(x :: Word8) (xs :: [Word8]) -> + not (List.null xs) + ==> Bytes.split x (slicedPack xs) + === map Bytes.fromByteArray (Exts.toList (Bytes.splitU x (slicedPack xs))) + , testCase "splitInit-A" $ + [Ascii.fromString "hello", Ascii.fromString "world"] + @=? (Bytes.splitInit 0x0A (Ascii.fromString "hello\nworld\n")) + , testCase "splitInit-B" $ + [Ascii.fromString "hello", Ascii.fromString "world"] + @=? (Bytes.splitInit 0x0A (Ascii.fromString "hello\nworld\nthere")) + , testProperty "replace" $ \(ws :: ASCIIString) (xs :: ASCIIString) (ys :: ASCIIString) (zs :: ASCIIString) -> + let ws' = asciiStringToBytes ws + xs' = asciiStringToBytes xs + ys' = asciiStringToBytes ys + zs' = asciiStringToBytes zs + ws'' = asciiStringToText ws + xs'' = asciiStringToText xs + ys'' = asciiStringToText ys + zs'' = asciiStringToText zs + in case ws of + ASCIIString [] -> property Discard + _ -> + Bytes.replace ws' xs' (ys' <> ws' <> zs') + === Bytes.fromByteString (Text.Encoding.encodeUtf8 (Text.replace ws'' xs'' (ys'' <> ws'' <> zs''))) + , testProperty "splitEnd1" $ \(x :: Word8) (xs :: [Word8]) -> + case ByteString.split x (ByteString.pack xs) of + [] -> Bytes.splitEnd1 x (slicedPack xs) === Nothing + [_] -> Bytes.splitEnd1 x (slicedPack xs) === Nothing + [y1, z1] -> case Bytes.splitEnd1 x (slicedPack xs) of + Nothing -> property False + Just (y2, z2) -> (y1, z1) === (bytesToByteString y2, bytesToByteString z2) + _ -> property Discard + , testProperty "split1" $ \(x :: Word8) (xs :: [Word8]) -> + case ByteString.split x (ByteString.pack xs) of + [] -> Bytes.split1 x (slicedPack xs) === Nothing + [_] -> Bytes.split1 x (slicedPack xs) === Nothing + [y1, z1] -> case Bytes.split1 x (slicedPack xs) of + Nothing -> property False + Just (y2, z2) -> (y1, z1) === (bytesToByteString y2, bytesToByteString z2) + _ -> property Discard + , testProperty "splitTetragram1A" $ \(w0 :: Word8) (w1 :: Word8) (w2 :: Word8) (w3 :: Word8) (xs :: [Word8]) -> + (w0 /= 0xEF && w1 /= 0xEF && w2 /= 0xEF && w3 /= 0xEF) + ==> case Bytes.splitTetragram1 w0 w1 w2 w3 (slicedPack (0xEF : w0 : w1 : w2 : w3 : xs)) of + Nothing -> property False + Just (pre, post) -> + (pre, post) === (Exts.fromList [0xEF], Exts.fromList xs) + , testProperty "splitTetragram1B" $ \(w0 :: Word8) (w1 :: Word8) (w2 :: Word8) (w3 :: Word8) (xs :: [Word8]) -> + (w0 /= 0xEF && w1 /= 0xEF && w2 /= 0xEF && w3 /= 0xEF) + ==> case Bytes.splitTetragram1 w0 w1 w2 w3 (slicedPack (0xEF : 0xEF : 0xEF : 0xEF : w0 : w1 : w2 : w3 : xs)) of + Nothing -> property False + Just (pre, post) -> + (pre, post) === (Exts.fromList (List.replicate 4 0xEF), Exts.fromList xs) + , testProperty "splitTetragram1C" $ \(w0 :: Word8) (w1 :: Word8) (w2 :: Word8) (xs :: [Word8]) -> + (w0 /= 0xEF && w1 /= 0xEF && w2 /= 0xEF) + ==> case Bytes.splitTetragram1 w0 w1 w2 0xEF (slicedPack (xs ++ [w0, w1, w2, 0xEF])) of + Nothing -> property False + Just (pre, post) -> + (pre, post) === (Exts.fromList xs, mempty) + , testProperty "splitTetragram1D" $ \(w0 :: Word8) (w1 :: Word8) (w2 :: Word8) (xs :: [Word8]) -> + (w0 /= 0xEF && w1 /= 0xEF && w2 /= 0xEF) + ==> case Bytes.splitTetragram1 w0 w1 w2 0xEF (slicedPack (xs ++ [w0, w1, w2, 0xEF, 0xEF])) of + Nothing -> property False + Just (pre, post) -> + (pre, post) === (Exts.fromList xs, Exts.fromList [0xEF]) + , testProperty "split2" $ \(xs :: [Word8]) (ys :: [Word8]) (zs :: [Word8]) -> + (all (/= 0xEF) xs && all (/= 0xEF) ys && all (/= 0xEF) zs) + ==> case Bytes.split2 0xEF (slicedPack (xs ++ [0xEF] ++ ys ++ [0xEF] ++ zs)) of + Just r -> r === (slicedPack xs, slicedPack ys, slicedPack zs) + Nothing -> property False + , testProperty "split3" $ \(ws :: [Word8]) (xs :: [Word8]) (ys :: [Word8]) (zs :: [Word8]) -> + (all (/= 0xEF) ws && all (/= 0xEF) xs && all (/= 0xEF) ys && all (/= 0xEF) zs) + ==> case Bytes.split3 0xEF (slicedPack (ws ++ [0xEF] ++ xs ++ [0xEF] ++ ys ++ [0xEF] ++ zs)) of + Just r -> r === (slicedPack ws, slicedPack xs, slicedPack ys, slicedPack zs) + Nothing -> property False + , testProperty "split4" $ \(ws :: [Word8]) (xs :: [Word8]) (ys :: [Word8]) (zs :: [Word8]) (ps :: [Word8]) -> + (all (/= 0xEF) ws && all (/= 0xEF) xs && all (/= 0xEF) ys && all (/= 0xEF) zs && all (/= 0xEF) ps) + ==> case Bytes.split4 0xEF (slicedPack (ws ++ [0xEF] ++ xs ++ [0xEF] ++ ys ++ [0xEF] ++ zs ++ [0xEF] ++ ps)) of + Just r -> r === (slicedPack ws, slicedPack xs, slicedPack ys, slicedPack zs, slicedPack ps) + Nothing -> property False + , testGroup + "FNV-1a" + [ testGroup + "32-bit" + [ testCase "empty" (Bytes.fnv1a32 Bytes.empty @=? 0x811c9dc5) + , testCase "a" (Bytes.fnv1a32 (bytes "a") @=? 0xe40c292c) + , testCase "foobar" (Bytes.fnv1a32 (bytes "foobar") @=? 0xbf9cf968) + ] + , testGroup + "64-bit" + [ testCase "empty" (Bytes.fnv1a64 Bytes.empty @=? 0xcbf29ce484222325) + , testCase "a" (Bytes.fnv1a64 (bytes "a") @=? 0xaf63dc4c8601ec8c) + , testCase "foobar" (Bytes.fnv1a64 (bytes "foobar") @=? 0x85944171f73967e8) + , testCase "google.com" (Bytes.fnv1a64 (bytes "google.com") @=? 0xe1a2c1ae38dcdf45) + ] + ] + , testGroup + "Chunks" + [ lawsToTest (QCC.eqLaws (Proxy :: Proxy Chunks)) + , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy Chunks)) + , lawsToTest (QCC.monoidLaws (Proxy :: Proxy Chunks)) + , testGroup + "concatenation" + [ testProperty "concat=concatU" $ \(c :: Chunks) -> + Chunks.concat c === Bytes.fromByteArray (Chunks.concatU c) + , testProperty "concat-singleton" $ \(b :: Bytes) -> + Chunks.concat (ChunksCons b ChunksNil) === b + , testProperty "concatU-singleton" $ \(b :: Bytes) -> + Chunks.concatU (ChunksCons b ChunksNil) === Bytes.toByteArray b + ] + ] ] - , testProperty "elem" $ \(x :: Word8) (xs :: [Word8]) -> - List.elem x xs - === - Bytes.elem x (Bytes.unsafeDrop 1 (Exts.fromList (x : xs))) - , testProperty "foldl" $ \(x :: Word8) (xs :: [Word8]) -> - List.foldl (-) 0 xs - === - Bytes.foldl (-) 0 (Bytes.unsafeDrop 1 (Exts.fromList (x : xs))) - , testProperty "foldl'" $ \(x :: Word8) (xs :: [Word8]) -> - List.foldl' (-) 0 xs - === - Bytes.foldl' (-) 0 (Bytes.unsafeDrop 1 (Exts.fromList (x : xs))) - , testProperty "foldr" $ \(x :: Word8) (xs :: [Word8]) -> - Foldable.foldr (-) 0 xs - === - Bytes.foldr (-) 0 (Bytes.unsafeDrop 1 (Exts.fromList (x : xs))) - , testProperty "foldr'" $ \(x :: Word8) (xs :: [Word8]) -> - Foldable.foldr' (-) 0 xs - === - Bytes.foldr' (-) 0 (Bytes.unsafeDrop 1 (Exts.fromList (x : xs))) - , testProperty "count" $ \(x :: Word8) (xs :: [Word8]) -> - ByteString.count x (ByteString.pack xs) - === - Bytes.count x (slicedPack xs) - , testProperty "split" $ \(x :: Word8) (xs :: [Word8]) -> - ByteString.split x (ByteString.pack xs) - === - map bytesToByteString (Bytes.split x (slicedPack xs)) - , testProperty "splitInit" $ \(x :: Word8) (xs :: [Word8]) -> case xs of - [] -> Bytes.splitInit x (slicedPack xs) === [] - _ -> - List.init (ByteString.split x (ByteString.pack xs)) - === - map bytesToByteString (Bytes.splitInit x (slicedPack xs)) - , testCase "splitInit-A" $ - [Bytes.fromAsciiString "hello", Bytes.fromAsciiString "world"] - @=? - (Bytes.splitInit 0x0A (Bytes.fromAsciiString "hello\nworld\n")) - , testCase "splitInit-B" $ - [Bytes.fromAsciiString "hello", Bytes.fromAsciiString "world"] - @=? - (Bytes.splitInit 0x0A (Bytes.fromAsciiString "hello\nworld\nthere")) - , testProperty "splitFirst" $ \(x :: Word8) (xs :: [Word8]) -> - case ByteString.split x (ByteString.pack xs) of - [] -> Bytes.splitFirst x (slicedPack xs) === Nothing - [_] -> Bytes.splitFirst x (slicedPack xs) === Nothing - [y1,z1] -> case Bytes.splitFirst x (slicedPack xs) of - Nothing -> property False - Just (y2,z2) -> (y1,z1) === (bytesToByteString y2, bytesToByteString z2) - _ -> property Discard - ] bytes :: String -> Bytes bytes s = let b = pack ('x' : s) in Bytes b 1 (PM.sizeofByteArray b - 1) @@ -136,3 +351,38 @@ bytesToByteString :: Bytes -> ByteString.ByteString bytesToByteString = ByteString.pack . Bytes.foldr (:) [] + +instance Arbitrary Bytes where + arbitrary = do + xs :: [Word8] <- TQC.arbitrary + front <- TQC.choose (0, 2) + back <- TQC.choose (0, 2) + let frontPad = replicate front (254 :: Word8) + let backPad = replicate back (254 :: Word8) + let raw = Exts.fromList (frontPad ++ xs ++ backPad) + pure (Bytes raw front (length xs)) + +instance Arbitrary Chunks where + arbitrary = do + xs :: [[Word8]] <- TQC.arbitrary + let ys = + map + (\x -> Exts.fromList ([255] ++ x ++ [255])) + xs + zs = + foldr + ( \b cs -> + ChunksCons (Bytes b 1 (PM.sizeofByteArray b - 2)) cs + ) + ChunksNil + ys + pure zs + +lawsToTest :: QCC.Laws -> TestTree +lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs) + +asciiStringToBytes :: ASCIIString -> Bytes +asciiStringToBytes (ASCIIString x) = bytes x + +asciiStringToText :: ASCIIString -> Text +asciiStringToText (ASCIIString x) = Text.pack x