diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index b683dfc40..92b8d4138 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -138,7 +138,7 @@ jobs: apt-get install -y ghc libghc-tasty-quickcheck-dev libghc-syb-dev run: | ghc --version - ghc --make -fPIC -XHaskell2010 -XBangPatterns -XDeriveDataTypeable -XDeriveGeneric -XDeriveLift -XFlexibleContexts -XFlexibleInstances -XLambdaCase -XMagicHash -XMultiWayIf -XNamedFieldPuns -XPatternSynonyms -XRankNTypes -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeOperators -XUnboxedTuples -optP-Wall -optP-Werror=undef -DPURE_HASKELL=0 -Iinclude -itests:tests/builder -o Main cbits/*.c tests/Main.hs +RTS -s + ghc --make -fPIC -XHaskell2010 -XBangPatterns -XDeriveDataTypeable -XDeriveGeneric -XDeriveLift -XFlexibleContexts -XFlexibleInstances -XLambdaCase -XMagicHash -XMultiWayIf -XNamedFieldPuns -XPatternSynonyms -XRankNTypes -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeOperators -XUnboxedTuples -optP-Wall -optP-Werror=undef -DPURE_HASKELL=0 -DBYTESTRING_PLUGIN_TESTS=0 -Iinclude -itests:tests/builder -o Main cbits/*.c tests/Main.hs +RTS -s ./Main +RTS -s bounds-checking: @@ -158,7 +158,7 @@ jobs: path: | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} dist-newstyle - key: ${{ runner.os }}-latest + key: ${{ runner.os }}-latest-bounds-checking - name: Test run: cabal test --ghc-options='-fcheck-prim-bounds -fno-ignore-asserts -DHS_BYTESTRING_ASSERTIONS' @@ -183,6 +183,27 @@ jobs: - name: Test run: cabal test -fpure-haskell --ghc-options=-fno-ignore-asserts --enable-tests --test-show-details=direct all + inspection-testing: + needs: build + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + - uses: haskell-actions/setup@v2 + id: setup-haskell-cabal + with: + ghc-version: 'latest' + - name: Update cabal package database + run: cabal update + - uses: actions/cache@v3 + name: Cache cabal stuff + with: + path: | + ${{ steps.setup-haskell-cabal.outputs.cabal-store }} + dist-newstyle + key: ${{ runner.os }}-latest-inspection-testing + - name: Test + run: sh run-plugin-tests.sh + i386: needs: build runs-on: ubuntu-latest diff --git a/Data/ByteString/Builder/Internal.hs b/Data/ByteString/Builder/Internal.hs index 8bb6278bd..12862016d 100644 --- a/Data/ByteString/Builder/Internal.hs +++ b/Data/ByteString/Builder/Internal.hs @@ -1,6 +1,8 @@ {-# LANGUAGE Unsafe #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK not-home #-} @@ -87,6 +89,8 @@ module Data.ByteString.Builder.Internal ( -- , sizedChunksInsert , byteStringCopy + , asciiLiteralCopy + , modUtf8LitCopy , byteStringInsert , byteStringThreshold @@ -816,6 +820,7 @@ ensureFree :: Int -> Builder ensureFree minFree = builder step where + step :: forall r. BuildStep r -> BuildStep r step k br@(BufferRange op ope) | ope `minusPtr` op < minFree = return $ bufferFull minFree op k | otherwise = k br @@ -839,6 +844,25 @@ wrappedBytesCopyStep bs0 k = where outRemaining = ope `minusPtr` op +-- | Copy the bytes from a 'BufferRange' into the output stream. +wrappedBufferRangeCopyStep :: BufferRange -- ^ Input 'BufferRange'. + -> BuildStep a -> BuildStep a +wrappedBufferRangeCopyStep (BufferRange ip0 ipe) k = + go ip0 + where + go !ip (BufferRange op ope) + | inpRemaining <= outRemaining = do + copyBytes op ip inpRemaining + let !br' = BufferRange (op `plusPtr` inpRemaining) ope + k br' + | otherwise = do + copyBytes op ip outRemaining + let !ip' = ip `plusPtr` outRemaining + return $ bufferFull 1 ope (go ip') + where + outRemaining = ope `minusPtr` op + inpRemaining = ipe `minusPtr` ip + -- Strict ByteStrings ------------------------------------------------------------------------------ @@ -858,6 +882,7 @@ byteStringThreshold :: Int -> S.StrictByteString -> Builder byteStringThreshold maxCopySize = \bs -> builder $ step bs where + step :: forall r. S.ByteString -> BuildStep r -> BuildStep r step bs@(S.BS _ len) k br@(BufferRange !op _) | len <= maxCopySize = byteStringCopyStep bs k br | otherwise = return $ insertChunk op bs k @@ -949,6 +974,88 @@ byteStringInsert :: S.StrictByteString -> Builder byteStringInsert = \bs -> builder $ \k (BufferRange op _) -> return $ insertChunk op bs k + +------------------------------------------------------------------------------ +-- Raw CString encoding +------------------------------------------------------------------------------ + +-- | Builder for raw pointers to static data of known length that will never be +-- moved or freed. (This is used with the static buffers GHC uses to implement +-- ASCII string literals that do not contain null characters.) +-- +-- @since 0.13.0.0 +{-# INLINABLE asciiLiteralCopy #-} +asciiLiteralCopy :: Ptr Word8 -> Int -> Builder +asciiLiteralCopy = \ !ip !len -> builder $ \k br@(BufferRange op ope) -> + if len <= ope `minusPtr` op + then copyBytes op ip len >> k (BufferRange (op `plusPtr` len) ope) + else wrappedBufferRangeCopyStep (BufferRange ip (ip `plusPtr` len)) k br + +-- | Builder for pointers to /null-terminated/ primitive UTF-8 encoded strings +-- that may contain embedded overlong two-byte encodings of the NUL character +-- as @0xC0 0x80@. Other deviations from strict UTF-8 are tolerated, but the +-- result is not well defined. +-- +-- @since 0.13.0.0 +{-# INLINABLE modUtf8LitCopy #-} +modUtf8LitCopy :: Ptr Word8 -> Int -> Builder +modUtf8LitCopy !ip !len + | len > 0 = builder (modUtf8_step ip len) + | otherwise = builder id + +-- | Copy a /non-empty/ UTF-8 input possibly containing denormalised 2-octet +-- sequences. While only the NUL byte should ever encoded that way (as @0xC0 +-- 80@), this handles other denormalised @0xC0 0x??@ sequences by keeping the +-- bottom 6 bits of the second byte. If the input is non-UTF8 garbage, the the +-- result may not be what the user expected. +-- +modUtf8_step :: Ptr Word8 -> Int -> BuildStep r -> BuildStep r +modUtf8_step !ip !len k (BufferRange op ope) + | op == ope = return $ bufferFull 1 op (modUtf8_step ip len k) + | otherwise = do + let !avail = ope `minusPtr` op + !usable = avail `min` len + -- null-termination makes it possible to read one more byte than the + -- nominal input length, with any unexpected 0xC000 ending interpreted + -- as a NUL. More typically, this simplifies hanlding of inputs where + -- 0xC0 0x80 might otherwise be split across the "usable" input window. + !ch <- peekElemOff ip (usable - 1) + let !use | ch /= 0xC0 = usable + | otherwise = usable + 1 + !n <- utf8_copyBytes (ip `plusPtr` use) ip op + let !op' = op `plusPtr` n + !len' = len - use + ip' = ip `plusPtr` use + if | len' <= 0 -> k (BufferRange op' ope) + | op' < ope -> modUtf8_step ip' len' k (BufferRange op' ope) + | otherwise -> return $ bufferFull 1 op' (modUtf8_step ip' len' k) + +-- | Consume the supplied input returning the number of bytes written +utf8_copyBytes :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO Int +utf8_copyBytes !ipe = \ ip op -> go 0 ip op + where + go :: Int -> Ptr Word8 -> Ptr Word8 -> IO Int + go !n !ip@((< ipe) -> True) !op = do + !ch <- peek ip + let !ip' = ip `plusPtr` 1 + !op' = op `plusPtr` 1 + if | ch /= 0xC0 -> do + poke op ch + let !cnt = ipe `minusPtr` ip' + !runend <- S.memchr ip' 0xC0 (fromIntegral @Int cnt) + let !runlen | runend == nullPtr = cnt + | otherwise = runend `minusPtr` ip' + if (runlen == 0) + then go (n + 1) ip' op' + else do + copyBytes op' ip' runlen + go (n + 1 + runlen) (ip' `plusPtr` runlen) (op' `plusPtr` runlen) + | otherwise -> do + !ch' <- peek ip' + poke op (ch' .&. 0x3f) + go (n + 1) (ip' `plusPtr` 1) op' + go !n _ _ = pure n + -- Short bytestrings ------------------------------------------------------------------------------ diff --git a/Data/ByteString/Builder/Prim.hs b/Data/ByteString/Builder/Prim.hs index 82f5d18a9..6f0cd09e5 100644 --- a/Data/ByteString/Builder/Prim.hs +++ b/Data/ByteString/Builder/Prim.hs @@ -453,6 +453,7 @@ import Data.ByteString.Builder.Internal import qualified Data.ByteString as S import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Internal.Type as S import qualified Data.ByteString.Lazy.Internal as L import Data.Char (ord) @@ -464,9 +465,7 @@ import Data.ByteString.Builder.Prim.ASCII import Foreign import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import GHC.Word (Word8 (..)) import GHC.Exts -import GHC.IO ------------------------------------------------------------------------------ -- Creating Builders from bounded primitives @@ -658,59 +657,22 @@ primMapLazyByteStringBounded w = L.foldrChunks (\x b -> primMapByteStringBounded w x `mappend` b) mempty ------------------------------------------------------------------------------- --- Raw CString encoding ------------------------------------------------------------------------------- - --- | A null-terminated ASCII encoded 'Foreign.C.String.CString'. --- Null characters are not representable. +-- | Builder for raw 'Addr#' pointers to null-terminated primitive ASCII +-- strings that are free of embedded null characters. -- -- @since 0.11.0.0 cstring :: Addr# -> Builder -cstring = - \addr0 -> builder $ step addr0 - where - step :: Addr# -> BuildStep r -> BuildStep r - step !addr !k br@(BufferRange op0@(Ptr op0#) ope) - | W8# ch == 0 = k br - | op0 == ope = - return $ bufferFull 1 op0 (step addr k) - | otherwise = do - IO $ \s -> case writeWord8OffAddr# op0# 0# ch s of - s' -> (# s', () #) - let br' = BufferRange (op0 `plusPtr` 1) ope - step (addr `plusAddr#` 1#) k br' - where - !ch = indexWord8OffAddr# addr 0# +cstring s = asciiLiteralCopy (Ptr s) (S.byteCountLiteral s) +{-# INLINE cstring #-} --- | A null-terminated UTF-8 encoded 'Foreign.C.String.CString'. --- Null characters can be encoded as @0xc0 0x80@. +-- | Builder for raw 'Addr#' pointers to null-terminated primitive UTF-8 +-- encoded strings in which any emebded null characters are represented via +-- the two-byte overlong-encoding: @0xC0 0x80@. -- -- @since 0.11.0.0 cstringUtf8 :: Addr# -> Builder -cstringUtf8 = - \addr0 -> builder $ step addr0 - where - step :: Addr# -> BuildStep r -> BuildStep r - step !addr !k br@(BufferRange op0@(Ptr op0#) ope) - | W8# ch == 0 = k br - | op0 == ope = - return $ bufferFull 1 op0 (step addr k) - -- NULL is encoded as 0xc0 0x80 - | W8# ch == 0xc0 - , W8# (indexWord8OffAddr# addr 1#) == 0x80 = do - let !(W8# nullByte#) = 0 - IO $ \s -> case writeWord8OffAddr# op0# 0# nullByte# s of - s' -> (# s', () #) - let br' = BufferRange (op0 `plusPtr` 1) ope - step (addr `plusAddr#` 2#) k br' - | otherwise = do - IO $ \s -> case writeWord8OffAddr# op0# 0# ch s of - s' -> (# s', () #) - let br' = BufferRange (op0 `plusPtr` 1) ope - step (addr `plusAddr#` 1#) k br' - where - !ch = indexWord8OffAddr# addr 0# +cstringUtf8 s = modUtf8LitCopy (Ptr s) (S.byteCountLiteral s) +{-# INLINE cstringUtf8 #-} ------------------------------------------------------------------------------ -- Char8 encoding diff --git a/Data/ByteString/Internal/Type.hs b/Data/ByteString/Internal/Type.hs index 0927771e1..725b43ec2 100644 --- a/Data/ByteString/Internal/Type.hs +++ b/Data/ByteString/Internal/Type.hs @@ -44,6 +44,7 @@ module Data.ByteString.Internal.Type ( unsafePackAddress, unsafePackLenAddress, unsafePackLiteral, unsafePackLenLiteral, literalFromOctetString, literalFromHex, + byteCountLiteral, -- * Low level imperative construction empty, @@ -486,6 +487,18 @@ unsafePackLenAddress len addr# = do #endif {-# INLINE unsafePackLenAddress #-} +-- | Byte count of null-terminated primitive literal string excluding the +-- terminating null byte. +byteCountLiteral :: Addr# -> Int +byteCountLiteral addr# = +#if HS_cstringLength_AND_FinalPtr_AVAILABLE + I# (cstringLength# addr#) +#else + fromIntegral @CSize @Int $ + accursedUnutterablePerformIO (c_strlen (Ptr addr#)) +#endif +{-# INLINE byteCountLiteral #-} + -- | See 'unsafePackAddress'. This function has similar behavior. Prefer -- this function when the address in known to be an @Addr#@ literal. In -- that context, there is no need for the sequencing guarantees that 'IO' diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs index 7f95a3e6f..e81f0e8d2 100644 --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -327,6 +327,10 @@ main = do , benchB'_ "ASCII String (12B)" $ asciiLit (Ptr "hello wurld!"#) , benchB' "ASCII String (64B, naive)" asciiStr fromString , benchB'_ "ASCII String (64B)" $ asciiLit asciiBuf + , benchB'_ "strLit" $ string8 asciiStr + , benchB'_ "stringUtf8" $ stringUtf8 utf8Str + , benchB'_ "strLitInline" $ string8 "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" + , benchB'_ "utf8LitInline" $ stringUtf8 "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX\0XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" ] , bgroup "Encoding wrappers" diff --git a/bytestring.cabal b/bytestring.cabal index dcdd35a0c..09879788c 100644 --- a/bytestring.cabal +++ b/bytestring.cabal @@ -216,8 +216,10 @@ test-suite bytestring-tests QuickCheckUtils hs-source-dirs: tests, tests/builder + build-depends: bytestring + -- Keep 'bytestring' on the same line as 'build-depends:' + -- this is used by our hack to allow plugin-based tests build-depends: base, - bytestring, deepseq, QuickCheck, tasty, @@ -226,6 +228,17 @@ test-suite bytestring-tests transformers >= 0.3, syb + -- The following intentionally-funnily-spelled condition + -- is changed to 'true' by our hack to allow plugin-based tests + if false && impl(pluginTestsHack) + cpp-options: -DBYTESTRING_PLUGIN_TESTS=1 + build-depends: tasty-inspection-testing ^>= 0.2.1, + tasty-expected-failure ^>= 0.12.3 + other-modules: PluginTests + PluginTests.Splices + else + cpp-options: -DBYTESTRING_PLUGIN_TESTS=0 + ghc-options: -fwarn-unused-binds -rtsopts if !arch(wasm32) @@ -249,8 +262,10 @@ benchmark bytestring-bench ghc-options: -O2 "-with-rtsopts=-A32m" -fproc-alignment=64 + build-depends: bytestring + -- Keep 'bytestring' on the same line as 'build-depends:' + -- this is used by our hack to allow plugin-based tests build-depends: base, - bytestring, deepseq, tasty-bench, random diff --git a/run-plugin-tests.sh b/run-plugin-tests.sh new file mode 100644 index 000000000..4f1bc306e --- /dev/null +++ b/run-plugin-tests.sh @@ -0,0 +1,14 @@ +# small script to hackily work around the dependency cycle +# 'bytestring -> [plugin] -> ghc -> bytestring' that prevents +# the testsuite from using plugins, by renaming the library +# to 'bytestring-plugins-hack' + +sed -E ' + /Name:|build-depends:/s/bytestring/bytestring-plugins-hack/ ; + s/if false && impl\(pluginTestsHack\)/if true/' \ + bytestring.cabal > bytestring-plugins-hack.cabal + +mv bytestring.cabal bytestring.cabal.__MOVED_DURING_PLUGIN_TESTS__ +cabal test --test-show-details=direct "$@" +mv bytestring.cabal.__MOVED_DURING_PLUGIN_TESTS__ bytestring.cabal +rm bytestring-plugins-hack.cabal diff --git a/tests/Main.hs b/tests/Main.hs index 043b5c415..b519e086c 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Main (main) where import Test.Tasty @@ -7,6 +9,9 @@ import qualified IsValidUtf8 import qualified LazyHClose import qualified Lift import qualified Properties +#if BYTESTRING_PLUGIN_TESTS +import qualified PluginTests +#endif main :: IO () main = defaultMain $ testGroup "All" @@ -15,4 +20,7 @@ main = defaultMain $ testGroup "All" , LazyHClose.testSuite , Lift.testSuite , Properties.testSuite +#if BYTESTRING_PLUGIN_TESTS + , PluginTests.testSuite +#endif ] diff --git a/tests/PluginTests.hs b/tests/PluginTests.hs new file mode 100644 index 000000000..70ceec904 --- /dev/null +++ b/tests/PluginTests.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -O -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-} + +module PluginTests (testSuite) where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BL8 +import Data.ByteString.Builder +import Data.Word + +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.Inspection + +import PluginTests.Splices + +testSuite :: TestTree +testSuite = testGroup "Inspection plugin tests" + [ testGroup "Literals" $ + [ testGroup "StrictByteString" + [ $(hasNoStringyStuff 'pack_strict_foo) + , $(inspectTest $ 'len_pack_strict_foo === 'literal_three) + , $(hasNoStringyStuff 'pack_strict_literal) + , $(inspectTest $ 'len_pack_strict_literal === 'literal_thirtyOne) + , expectFail $ $(hasNoStringyStuff 'pack_strict_nonAscii) + , expectFail $ $(hasNoStringyStuff 'pack_strict_literal_nonAscii) + ] + + , testGroup "Builder" + [ $(hasNoStringyStuff 'builder_string8_foo) + , $(hasNoStringyStuff 'builder_string8_literal) + , $(hasNoStringyStuff 'builder_stringUtf8_foo) + , $(hasNoStringyStuff 'builder_stringUtf8_literal) + , $(hasNoStringyStuff 'builder_stringUtf8_nonAscii) + , $(hasNoStringyStuff 'builder_stringUtf8_literal_nonAscii) + ] + ] + + , $(inspectTest $ 'append_pack_replicate_unboxing `hasNoType` ''S.ByteString) + ] + +foo_string_literal :: [Char] +foo_string_literal = "foo" + +unicode_string_literal :: [Char] +unicode_string_literal = "\0example\0 ... \xff \x1f530" + +pack_strict_foo :: S.ByteString +pack_strict_foo = S8.pack foo_string_literal + +len_pack_strict_foo :: Int +len_pack_strict_foo = S.length pack_strict_foo + +pack_strict_literal :: S.ByteString +pack_strict_literal = S8.pack "some ascii literal of length 31" + +len_pack_strict_literal :: Int +len_pack_strict_literal = S.length pack_strict_literal + +pack_strict_nonAscii :: S.ByteString +pack_strict_nonAscii = S8.pack unicode_string_literal + +pack_strict_literal_nonAscii :: S.ByteString +pack_strict_literal_nonAscii + = S8.pack "this\0literal contains\x80\xf0\xff non-ascii characters" + +literal_three :: Int +literal_three = 3 + +literal_thirtyOne :: Int +literal_thirtyOne = 31 + +builder_string8_foo :: Builder +builder_string8_foo = string8 foo_string_literal + +builder_string8_literal :: Builder +builder_string8_literal = string8 "some ascii string literal" + +builder_stringUtf8_foo :: Builder +builder_stringUtf8_foo = stringUtf8 foo_string_literal + +builder_stringUtf8_literal :: Builder +builder_stringUtf8_literal = stringUtf8 "some other ascii string literal" + +builder_stringUtf8_nonAscii :: Builder +builder_stringUtf8_nonAscii = stringUtf8 unicode_string_literal + +builder_stringUtf8_literal_nonAscii :: Builder +builder_stringUtf8_literal_nonAscii + = stringUtf8 "inline literal string containing \0special\0 and non-ASCII characters like \x2139" + +append_pack_replicate_unboxing :: Int -> Word8 -> Int +append_pack_replicate_unboxing n c + = S.count c $ S.append (S.pack [0..c]) (S.replicate n c) + diff --git a/tests/PluginTests/Splices.hs b/tests/PluginTests/Splices.hs new file mode 100644 index 000000000..7cd30f5a0 --- /dev/null +++ b/tests/PluginTests/Splices.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module PluginTests.Splices where + +import Test.Tasty +import Test.Tasty.Inspection +import Language.Haskell.TH + +import GHC.Base + ( unpackCString# + , unpackAppendCString# + , unpackCStringUtf8# + , unpackAppendCStringUtf8# + , unpackNBytes# + , unpackFoldrCString# + , unpackFoldrCStringUtf8# + ) +import Language.Haskell.TH (Name) + +unpackCString_functions_without_foldr :: [Name] +unpackCString_functions_without_foldr = + [ 'unpackCString# + , 'unpackAppendCString# + , 'unpackCStringUtf8# + , 'unpackAppendCStringUtf8# + , 'unpackNBytes# + ] + +unpackCString_functions_all :: [Name] +unpackCString_functions_all = + [ 'unpackFoldrCString# + , 'unpackFoldrCStringUtf8# + ] ++ unpackCString_functions_without_foldr + +hasNoStringyStuff :: Name -> Q Exp +hasNoStringyStuff n = flip inspectObligations n + [ (`hasNoTypes` [''Char, ''[]]) + , (`doesNotUseAnyOf` unpackCString_functions_all) + ] + +hasNoStringyStuffExceptFolds :: Name -> Q Exp +hasNoStringyStuffExceptFolds n = flip inspectObligations n + [ (`hasNoTypes` [''Char, ''[]]) + , (`doesNotUseAnyOf` unpackCString_functions_without_foldr) + ] diff --git a/tests/builder/Data/ByteString/Builder/Prim/Tests.hs b/tests/builder/Data/ByteString/Builder/Prim/Tests.hs index 60e0cf4a8..c9f5d5abd 100644 --- a/tests/builder/Data/ByteString/Builder/Prim/Tests.hs +++ b/tests/builder/Data/ByteString/Builder/Prim/Tests.hs @@ -14,6 +14,7 @@ import Data.Char (ord) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import Data.ByteString.Builder +import Data.ByteString.Builder.Extra as BE import qualified Data.ByteString.Builder.Prim as BP import Data.ByteString.Builder.Prim.TestUtils @@ -22,17 +23,28 @@ import Test.Tasty.QuickCheck tests :: [TestTree] tests = concat [ testsBinary, testsASCII, testsChar8, testsUtf8 - , testsCombinatorsB, [testCString, testCStringUtf8] ] + , testsCombinatorsB + , [ testCString + , testCStringUtf8 1 + , testCStringUtf8 6 + , testCStringUtf8 64 + ] + ] testCString :: TestTree testCString = testProperty "cstring" $ toLazyByteString (BP.cstring "hello world!"#) == LC.pack "hello" `L.append` L.singleton 0x20 `L.append` LC.pack "world!" -testCStringUtf8 :: TestTree -testCStringUtf8 = testProperty "cstringUtf8" $ - toLazyByteString (BP.cstringUtf8 "hello\xc0\x80world!"#) == - LC.pack "hello" `L.append` L.singleton 0x00 `L.append` LC.pack "world!" +testCStringUtf8 :: Int -> TestTree +testCStringUtf8 sz = testProperty "cstringUtf8" $ + BE.toLazyByteStringWith (BE.untrimmedStrategy sz sz) L.empty + (BP.cstringUtf8 "hello\xc0\x80\xc0\x80\xd0\xbc\xd0\xb8\xd1\x80\xc0\x80\xC0"#) == + LC.pack "hello" `L.append` L.singleton 0x00 + `L.append` L.singleton 0x00 + `L.append` LC.pack "\xd0\xbc\xd0\xb8\xd1\x80" + `L.append` L.singleton 0x00 + `L.append` L.singleton 0x00 ------------------------------------------------------------------------------ -- Binary