diff --git a/cbits/validate_utf8.cpp b/cbits/validate_utf8.cpp --- a/cbits/validate_utf8.cpp +++ b/cbits/validate_utf8.cpp @@ -4,3 +4,8 @@ int _hs_text_is_valid_utf8(const char* str, size_t len){ return simdutf::validate_utf8(str, len); } + +extern "C" +int _hs_text_is_valid_utf8_offset(const char* str, size_t off, size_t len){ + return simdutf::validate_utf8(str + off, len); +} diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,17 @@ +### 2.1 + +* [Switch `Data.Text.Array` to `Data.Array.Byte`](https://github.com/haskell/text/pull/474) + +* [Add `Text.IO.Utf8` module](https://github.com/haskell/text/pull/503) + +* [Expose UTF-8 validation functions from internal module](https://github.com/haskell/text/pull/483) + +* [Fix handling of incomplete input in stream decoders](https://github.com/haskell/text/pull/527) + +* [Fix handling of invalid bytes in stream decoders](https://github.com/haskell/text/pull/528) + +* [Make Lift Text work under RebindableSyntax](https://github.com/haskell/text/pull/534) + ### 2.0.2 * [Add decoding functions in `Data.Text.Encoding` that allow diff --git a/scripts/CaseFoldExceptions.hs b/scripts/CaseFoldExceptions.hs new file mode 100644 --- /dev/null +++ b/scripts/CaseFoldExceptions.hs @@ -0,0 +1,17 @@ +-- Generates exceptions for tests/Tests/Properties/Text.hs +-- runghc CaseFoldExceptions.txt + +import qualified Data.Char +import Data.List +import qualified Data.Text as T + +toCaseFoldExceptions :: String +toCaseFoldExceptions = filter (\c -> c `notElem` (cherokeeUpper ++ cherokeeLower)) $ + filter (\c -> T.toCaseFold (T.singleton c) /= T.singleton (Data.Char.toLower c)) + [minBound .. maxBound] + +cherokeeUpper = ['\x13A0'..'\x13F7'] -- x13F8..13FF are lowercase +cherokeeLower = ['\xAB70'..'\xABBF'] + +main :: IO () +main = print toCaseFoldExceptions diff --git a/src/Data/Text.hs b/src/Data/Text.hs --- a/src/Data/Text.hs +++ b/src/Data/Text.hs @@ -418,8 +418,10 @@ #if MIN_VERSION_template_haskell(2,16,0) lift txt = do let (ptr, len) = unsafePerformIO $ asForeignPtr txt - let lenInt = P.fromIntegral len - TH.appE (TH.appE (TH.varE 'unpackCStringLen#) (TH.litE . TH.bytesPrimL $ TH.mkBytes ptr 0 lenInt)) (TH.lift lenInt) + bytesQ = TH.litE . TH.bytesPrimL $ TH.mkBytes ptr 0 (P.fromIntegral len) + lenQ = liftInt (P.fromIntegral len) + liftInt n = (TH.appE (TH.conE 'Exts.I#) (TH.litE (TH.IntPrimL n))) + TH.varE 'unpackCStringLen# `TH.appE` bytesQ `TH.appE` lenQ #else lift = TH.appE (TH.varE 'pack) . TH.stringE . unpack #endif diff --git a/src/Data/Text/Array.hs b/src/Data/Text/Array.hs --- a/src/Data/Text/Array.hs +++ b/src/Data/Text/Array.hs @@ -1,5 +1,12 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, RankNTypes, - RecordWildCards, UnboxedTuples, UnliftedFFITypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} + {-# OPTIONS_GHC -fno-warn-unused-matches #-} -- | -- Module : Data.Text.Array @@ -24,8 +31,10 @@ module Data.Text.Array ( -- * Types - Array(..) - , MArray(..) + Array + , pattern ByteArray + , MArray + , pattern MutableByteArray -- * Functions , resizeM , shrinkM @@ -60,12 +69,13 @@ import GHC.Word (Word8(..)) import qualified Prelude import Prelude hiding (length, read, compare) +import Data.Array.Byte (ByteArray(..), MutableByteArray(..)) -- | Immutable array type. -data Array = ByteArray ByteArray# +type Array = ByteArray -- | Mutable array type, for use in the ST monad. -data MArray s = MutableByteArray (MutableByteArray# s) +type MArray = MutableByteArray -- | Create an uninitialized mutable array. new :: forall s. Int -> ST s (MArray s) diff --git a/src/Data/Text/IO.hs b/src/Data/Text/IO.hs --- a/src/Data/Text/IO.hs +++ b/src/Data/Text/IO.hs @@ -13,8 +13,11 @@ -- The functions in this module obey the runtime system's locale, -- character set encoding, and line ending conversion settings. -- +-- If you want to do I\/O using the UTF-8 encoding, use @Data.Text.IO.Utf8@, +-- which is faster than this module. +-- -- If you know in advance that you will be working with data that has --- a specific encoding (e.g. UTF-8), and your application is highly +-- a specific encoding, and your application is highly -- performance sensitive, you may find that it is faster to perform -- I\/O with bytestrings and to encode and decode yourself than to use -- the functions in this module. diff --git a/src/Data/Text/IO/Utf8.hs b/src/Data/Text/IO/Utf8.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/IO/Utf8.hs @@ -0,0 +1,93 @@ +-- | +-- Module : Data.Text.IO.Utf8 +-- License : BSD-style +-- Portability : GHC +-- +-- Efficient UTF-8 support for text I\/O. +-- Unlike @Data.Text.IO@, these functions do not depend on the locale +-- and do not do line ending conversion. +module Data.Text.IO.Utf8 + ( + -- * File-at-a-time operations + readFile + , writeFile + , appendFile + -- * Operations on handles + , hGetContents + , hGetLine + , hPutStr + , hPutStrLn + -- * Special cases for standard input and output + , interact + , getContents + , getLine + , putStr + , putStrLn + ) where + +import Prelude hiding (readFile, writeFile, appendFile, interact, getContents, getLine, putStr, putStrLn) +import Control.Exception (evaluate) +import Control.Monad ((<=<)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import GHC.IO.Handle (Handle) +import qualified Data.ByteString.Char8 as B.Char8 + +decodeUtf8IO :: ByteString -> IO Text +decodeUtf8IO = evaluate . decodeUtf8 + +-- | The 'readFile' function reads a file and returns the contents of +-- the file as a string. The entire file is read strictly, as with +-- 'getContents'. +readFile :: FilePath -> IO Text +readFile = decodeUtf8IO <=< B.readFile + +-- | Write a string to a file. The file is truncated to zero length +-- before writing begins. +writeFile :: FilePath -> Text -> IO () +writeFile fp = B.writeFile fp . encodeUtf8 + +-- | Write a string to the end of a file. +appendFile :: FilePath -> Text -> IO () +appendFile fp = B.appendFile fp . encodeUtf8 + +-- | Read the remaining contents of a 'Handle' as a string. +hGetContents :: Handle -> IO Text +hGetContents = decodeUtf8IO <=< B.hGetContents + +-- | Read a single line from a handle. +hGetLine :: Handle -> IO Text +hGetLine = decodeUtf8IO <=< B.hGetLine + +-- | Write a string to a handle. +hPutStr :: Handle -> Text -> IO () +hPutStr h = B.hPutStr h . encodeUtf8 + +-- | Write a string to a handle, followed by a newline. +hPutStrLn :: Handle -> Text -> IO () +hPutStrLn h t = hPutStr h t >> B.hPutStr h (B.Char8.singleton '\n') + +-- | The 'interact' function takes a function of type @Text -> Text@ +-- as its argument. The entire input from the standard input device is +-- passed to this function as its argument, and the resulting string +-- is output on the standard output device. +interact :: (Text -> Text) -> IO () +interact f = putStr . f =<< getContents + +-- | Read all user input on 'stdin' as a single string. +getContents :: IO Text +getContents = decodeUtf8IO =<< B.getContents + +-- | Read a single line of user input from 'stdin'. +getLine :: IO Text +getLine = decodeUtf8IO =<< B.getLine + +-- | Write a string to 'stdout'. +putStr :: Text -> IO () +putStr = B.putStr . encodeUtf8 + +-- | Write a string to 'stdout', followed by a newline. +putStrLn :: Text -> IO () +putStrLn t = B.putStr (encodeUtf8 t) >> B.putStr (B.Char8.singleton '\n') diff --git a/src/Data/Text/Internal/Encoding.hs b/src/Data/Text/Internal/Encoding.hs --- a/src/Data/Text/Internal/Encoding.hs +++ b/src/Data/Text/Internal/Encoding.hs @@ -244,7 +244,8 @@ {-# INLINE validateUtf8ChunkFrom #-} validateUtf8ChunkFrom :: forall r. Int -> ByteString -> (Int -> Maybe Utf8State -> r) -> r validateUtf8ChunkFrom ofs bs k -#if defined(SIMDUTF) || MIN_VERSION_bytestring(0,11,2) + -- B.isValidUtf8 is buggy before bytestring-0.11.5.0 +#if defined(SIMDUTF) || MIN_VERSION_bytestring(0,11,5) | guessUtf8Boundary > 0 && -- the rest of the bytestring is valid utf-8 up to the boundary ( diff --git a/src/Data/Text/Internal/Encoding/Fusion.hs b/src/Data/Text/Internal/Encoding/Fusion.hs --- a/src/Data/Text/Internal/Encoding/Fusion.hs +++ b/src/Data/Text/Internal/Encoding/Fusion.hs @@ -38,7 +38,7 @@ import Control.Exception (assert) #endif import Data.Bits (shiftL, shiftR) -import Data.ByteString.Internal (ByteString(..), mallocByteString, memcpy) +import Data.ByteString.Internal (ByteString(..), mallocByteString) import Data.Text.Internal.Fusion (Step(..), Stream(..)) import Data.Text.Internal.Fusion.Size import Data.Text.Encoding.Error @@ -47,6 +47,7 @@ import Data.Text.Internal.Unsafe (unsafeWithForeignPtr) import Data.Word (Word8, Word16, Word32) import Foreign.ForeignPtr (ForeignPtr) +import Foreign.Marshal.Utils (copyBytes) import Foreign.Storable (pokeByteOff) import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as B @@ -197,7 +198,7 @@ dest <- mallocByteString destLen unsafeWithForeignPtr src $ \src' -> unsafeWithForeignPtr dest $ \dest' -> - memcpy dest' src' srcLen + copyBytes dest' src' srcLen return dest decodeError :: forall s. String -> String -> OnDecodeError -> Maybe Word8 diff --git a/src/Data/Text/Internal/Lazy/Encoding/Fusion.hs b/src/Data/Text/Internal/Lazy/Encoding/Fusion.hs --- a/src/Data/Text/Internal/Lazy/Encoding/Fusion.hs +++ b/src/Data/Text/Internal/Lazy/Encoding/Fusion.hs @@ -49,8 +49,9 @@ import qualified Data.Text.Internal.Encoding.Utf32 as U32 import Data.Text.Unsafe (unsafeDupablePerformIO) import Foreign.ForeignPtr (ForeignPtr) +import Foreign.Marshal.Utils (copyBytes) import Foreign.Storable (pokeByteOff) -import Data.ByteString.Internal (mallocByteString, memcpy) +import Data.ByteString.Internal (mallocByteString) #if defined(ASSERTS) import Control.Exception (assert) #endif @@ -99,10 +100,10 @@ S2 a b -> next (T bs (S3 a b x) (i+1)) S3 a b c -> next (T bs (S4 a b c x) (i+1)) S4 a b c d -> decodeError "streamUtf8" "UTF-8" onErr (Just a) - (T bs (S3 b c d) (i+1)) + (T bs (S4 b c d x) (i+1)) where x = B.unsafeIndex ps i consume (T Empty S0 _) = Done - consume st = decodeError "streamUtf8" "UTF-8" onErr Nothing st + consume (T Empty _ i) = decodeError "streamUtf8" "UTF-8" onErr Nothing (T Empty S0 i) {-# INLINE [0] streamUtf8 #-} -- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little @@ -139,10 +140,10 @@ S2 w1 w2 -> next (T bs (S3 w1 w2 x) (i+1)) S3 w1 w2 w3 -> next (T bs (S4 w1 w2 w3 x) (i+1)) S4 w1 w2 w3 w4 -> decodeError "streamUtf16LE" "UTF-16LE" onErr (Just w1) - (T bs (S3 w2 w3 w4) (i+1)) + (T bs (S4 w2 w3 w4 x) (i+1)) where x = B.unsafeIndex ps i consume (T Empty S0 _) = Done - consume st = decodeError "streamUtf16LE" "UTF-16LE" onErr Nothing st + consume (T Empty _ i) = decodeError "streamUtf16LE" "UTF-16LE" onErr Nothing (T Empty S0 i) {-# INLINE [0] streamUtf16LE #-} -- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big @@ -179,10 +180,10 @@ S2 w1 w2 -> next (T bs (S3 w1 w2 x) (i+1)) S3 w1 w2 w3 -> next (T bs (S4 w1 w2 w3 x) (i+1)) S4 w1 w2 w3 w4 -> decodeError "streamUtf16BE" "UTF-16BE" onErr (Just w1) - (T bs (S3 w2 w3 w4) (i+1)) + (T bs (S4 w2 w3 w4 x) (i+1)) where x = B.unsafeIndex ps i consume (T Empty S0 _) = Done - consume st = decodeError "streamUtf16BE" "UTF-16BE" onErr Nothing st + consume (T Empty _ i) = decodeError "streamUtf16BE" "UTF-16BE" onErr Nothing (T Empty S0 i) {-# INLINE [0] streamUtf16BE #-} -- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big @@ -223,10 +224,10 @@ S2 w1 w2 -> next (T bs (S3 w1 w2 x) (i+1)) S3 w1 w2 w3 -> next (T bs (S4 w1 w2 w3 x) (i+1)) S4 w1 w2 w3 w4 -> decodeError "streamUtf32BE" "UTF-32BE" onErr (Just w1) - (T bs (S3 w2 w3 w4) (i+1)) + (T bs (S4 w2 w3 w4 x) (i+1)) where x = B.unsafeIndex ps i consume (T Empty S0 _) = Done - consume st = decodeError "streamUtf32BE" "UTF-32BE" onErr Nothing st + consume (T Empty _ i) = decodeError "streamUtf32BE" "UTF-32BE" onErr Nothing (T Empty S0 i) {-# INLINE [0] streamUtf32BE #-} -- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little @@ -267,10 +268,10 @@ S2 w1 w2 -> next (T bs (S3 w1 w2 x) (i+1)) S3 w1 w2 w3 -> next (T bs (S4 w1 w2 w3 x) (i+1)) S4 w1 w2 w3 w4 -> decodeError "streamUtf32LE" "UTF-32LE" onErr (Just w1) - (T bs (S3 w2 w3 w4) (i+1)) + (T bs (S4 w2 w3 w4 x) (i+1)) where x = B.unsafeIndex ps i consume (T Empty S0 _) = Done - consume st = decodeError "streamUtf32LE" "UTF-32LE" onErr Nothing st + consume (T Empty _ i) = decodeError "streamUtf32LE" "UTF-32LE" onErr Nothing (T Empty S0 i) {-# INLINE [0] streamUtf32LE #-} -- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'. @@ -308,7 +309,7 @@ dest <- mallocByteString destLen unsafeWithForeignPtr src $ \src' -> unsafeWithForeignPtr dest $ \dest' -> - memcpy dest' src' srcLen + copyBytes dest' src' srcLen return dest -- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'. diff --git a/src/Data/Text/Internal/PrimCompat.hs b/src/Data/Text/Internal/PrimCompat.hs --- a/src/Data/Text/Internal/PrimCompat.hs +++ b/src/Data/Text/Internal/PrimCompat.hs @@ -13,13 +13,12 @@ ) where #if MIN_VERSION_base(4,16,0) - -import GHC.Base - +import GHC.Exts (wordToWord8#,word8ToWord#,wordToWord16#,word16ToWord#,wordToWord32#,word32ToWord#) #else - import GHC.Prim (Word#) +#endif +#if !(MIN_VERSION_base(4,16,0)) wordToWord8#, word8ToWord# :: Word# -> Word# wordToWord16#, word16ToWord# :: Word# -> Word# wordToWord32#, word32ToWord# :: Word# -> Word# @@ -33,5 +32,4 @@ {-# INLINE word16ToWord# #-} {-# INLINE wordToWord32# #-} {-# INLINE word32ToWord# #-} - #endif diff --git a/src/Data/Text/Internal/Validate.hs b/src/Data/Text/Internal/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Internal/Validate.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + +-- | Test whether or not a sequence of bytes is a valid UTF-8 byte sequence. +-- In the GHC Haskell ecosystem, there are several representations of byte +-- sequences. The only one that the stable @text@ API concerns itself with is +-- 'ByteString'. Part of bytestring-to-text decoding is 'isValidUtf8ByteString', +-- a high-performance UTF-8 validation routine written in C++ with fallbacks +-- for various platforms. The C++ code backing this routine is nontrivial, +-- so in the interest of reuse, this module additionally exports functions +-- for working with the GC-managed @ByteArray@ type. These @ByteArray@ +-- functions are not used anywhere else in @text@. They are for the benefit +-- of library and application authors who do not use 'ByteString' but still +-- need to interoperate with @text@. +module Data.Text.Internal.Validate + ( + -- * ByteString + isValidUtf8ByteString + -- * ByteArray + -- + -- | Is the slice of a byte array a valid UTF-8 byte sequence? These + -- functions all accept an offset and a length. + , isValidUtf8ByteArray + , isValidUtf8ByteArrayUnpinned + , isValidUtf8ByteArrayPinned + ) where + +import Data.Array.Byte (ByteArray(ByteArray)) +import Data.ByteString (ByteString) +import GHC.Exts (isTrue#,isByteArrayPinned#) + +#ifdef SIMDUTF +import Data.Text.Unsafe (unsafeDupablePerformIO) +import Data.Text.Internal.ByteStringCompat (withBS) +import Data.Text.Internal.Unsafe (unsafeWithForeignPtr) +import Data.Text.Internal.Validate.Simd (c_is_valid_utf8_bytearray_safe,c_is_valid_utf8_bytearray_unsafe,c_is_valid_utf8_ptr_unsafe) +#else +import GHC.Exts (ByteArray#) +import Data.Text.Internal.Encoding.Utf8 (CodePoint(..),DecoderResult(..),utf8DecodeStart,utf8DecodeContinue) +import GHC.Exts (Int(I#),indexWord8Array#) +import GHC.Word (Word8(W8#)) +import qualified Data.ByteString as B +#if !MIN_VERSION_bytestring(0,11,2) +import qualified Data.ByteString.Unsafe as B +#endif +#endif + +-- | Is the ByteString a valid UTF-8 byte sequence? +isValidUtf8ByteString :: ByteString -> Bool +#ifdef SIMDUTF +isValidUtf8ByteString bs = withBS bs $ \fp len -> unsafeDupablePerformIO $ + unsafeWithForeignPtr fp $ \ptr -> (/= 0) <$> c_is_valid_utf8_ptr_unsafe ptr (fromIntegral len) +#else +#if MIN_VERSION_bytestring(0,11,2) +isValidUtf8ByteString = B.isValidUtf8 +#else +isValidUtf8ByteString bs = start 0 + where + start ix + | ix >= B.length bs = True + | otherwise = case utf8DecodeStart (B.unsafeIndex bs ix) of + Accept{} -> start (ix + 1) + Reject{} -> False + Incomplete st _ -> step (ix + 1) st + step ix st + | ix >= B.length bs = False + -- We do not use decoded code point, so passing a dummy value to save an argument. + | otherwise = case utf8DecodeContinue (B.unsafeIndex bs ix) st (CodePoint 0) of + Accept{} -> start (ix + 1) + Reject{} -> False + Incomplete st' _ -> step (ix + 1) st' +#endif +#endif + +-- | For pinned byte arrays larger than 128KiB, this switches to the safe FFI +-- so that it does not prevent GC. This threshold (128KiB) was chosen +-- somewhat arbitrarily and may change in the future. +isValidUtf8ByteArray :: + ByteArray -- ^ Bytes + -> Int -- ^ Offset + -> Int -- ^ Length + -> Bool +isValidUtf8ByteArray b@(ByteArray b#) !off !len + | len >= 131072 -- 128KiB + , isTrue# (isByteArrayPinned# b#) + = isValidUtf8ByteArrayPinned b off len + | otherwise = isValidUtf8ByteArrayUnpinned b off len + +-- | This uses the @unsafe@ FFI. GC waits for all @unsafe@ FFI calls +-- to complete before starting. Consequently, an @unsafe@ FFI call does not +-- run concurrently with GC and is not interrupted by GC. Since relocation +-- cannot happen concurrently with an @unsafe@ FFI call, it is safe +-- to call this function with an unpinned byte array argument. +-- It is also safe to call this with a pinned @ByteArray@ argument. +isValidUtf8ByteArrayUnpinned :: + ByteArray -- ^ Bytes + -> Int -- ^ Offset + -> Int -- ^ Length + -> Bool +#ifdef SIMDUTF +isValidUtf8ByteArrayUnpinned (ByteArray bs) !off !len = + unsafeDupablePerformIO $ (/= 0) <$> c_is_valid_utf8_bytearray_unsafe bs (fromIntegral off) (fromIntegral len) +#else +isValidUtf8ByteArrayUnpinned (ByteArray bs) = isValidUtf8ByteArrayHaskell# bs +#endif + +-- | This uses the @safe@ FFI. GC may run concurrently with @safe@ +-- FFI calls. Consequently, unpinned objects may be relocated while a +-- @safe@ FFI call is executing. The byte array argument /must/ be pinned, +-- and the calling context is responsible for enforcing this. If the +-- byte array is not pinned, this function's behavior is undefined. +isValidUtf8ByteArrayPinned :: + ByteArray -- ^ Bytes + -> Int -- ^ Offset + -> Int -- ^ Length + -> Bool +#ifdef SIMDUTF +isValidUtf8ByteArrayPinned (ByteArray bs) !off !len = + unsafeDupablePerformIO $ (/= 0) <$> c_is_valid_utf8_bytearray_safe bs (fromIntegral off) (fromIntegral len) +#else +isValidUtf8ByteArrayPinned (ByteArray bs) = isValidUtf8ByteArrayHaskell# bs +#endif + +#ifndef SIMDUTF +isValidUtf8ByteArrayHaskell# :: + ByteArray# -- ^ Bytes + -> Int -- ^ Offset + -> Int -- ^ Length + -> Bool +isValidUtf8ByteArrayHaskell# b !off !len = start off + where + indexWord8 :: ByteArray# -> Int -> Word8 + indexWord8 !x (I# i) = W8# (indexWord8Array# x i) + start ix + | ix >= len = True + | otherwise = case utf8DecodeStart (indexWord8 b ix) of + Accept{} -> start (ix + 1) + Reject{} -> False + Incomplete st _ -> step (ix + 1) st + step ix st + | ix >= len = False + -- We do not use decoded code point, so passing a dummy value to save an argument. + | otherwise = case utf8DecodeContinue (indexWord8 b ix) st (CodePoint 0) of + Accept{} -> start (ix + 1) + Reject{} -> False + Incomplete st' _ -> step (ix + 1) st' +#endif diff --git a/src/Data/Text/Internal/Validate/Simd.hs b/src/Data/Text/Internal/Validate/Simd.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Internal/Validate/Simd.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + +-- | Validate that a byte sequence is UTF-8-encoded text. All of these +-- functions return zero when the byte sequence is not UTF-8-encoded text, +-- and they return an unspecified non-zero value when the byte sequence +-- is UTF-8-encoded text. +-- +-- Variants are provided for both @ByteArray#@ and @Ptr@. Additionally, +-- variants are provided that use both the @safe@ and @unsafe@ FFI. +-- +-- If compiling with SIMDUTF turned off, this module exports nothing. +module Data.Text.Internal.Validate.Simd + ( c_is_valid_utf8_ptr_unsafe + , c_is_valid_utf8_ptr_safe + , c_is_valid_utf8_bytearray_unsafe + , c_is_valid_utf8_bytearray_safe + ) where + +import Data.Word (Word8) +import Foreign.C.Types (CSize(..),CInt(..)) +import GHC.Exts (Ptr,ByteArray#) + +foreign import ccall unsafe "_hs_text_is_valid_utf8" c_is_valid_utf8_ptr_unsafe + :: Ptr Word8 -- ^ Bytes + -> CSize -- ^ Length + -> IO CInt +foreign import ccall safe "_hs_text_is_valid_utf8" c_is_valid_utf8_ptr_safe + :: Ptr Word8 -- ^ Bytes + -> CSize -- ^ Length + -> IO CInt +foreign import ccall unsafe "_hs_text_is_valid_utf8_offset" c_is_valid_utf8_bytearray_unsafe + :: ByteArray# -- ^ Bytes + -> CSize -- ^ Offset into bytes + -> CSize -- ^ Length + -> IO CInt +foreign import ccall safe "_hs_text_is_valid_utf8_offset" c_is_valid_utf8_bytearray_safe + :: ByteArray# -- ^ Bytes + -> CSize -- ^ Offset into bytes + -> CSize -- ^ Length + -> IO CInt diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -9,10 +9,12 @@ import qualified Tests.Lift as Lift import qualified Tests.Properties as Properties import qualified Tests.Regressions as Regressions +import qualified Tests.RebindableSyntaxTest as RST main :: IO () main = defaultMain $ testGroup "All" [ Lift.tests , Properties.tests , Regressions.tests + , RST.tests ] diff --git a/tests/Tests/Properties/LowLevel.hs b/tests/Tests/Properties/LowLevel.hs --- a/tests/Tests/Properties/LowLevel.hs +++ b/tests/Tests/Properties/LowLevel.hs @@ -31,6 +31,7 @@ import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TL +import qualified Data.Text.IO.Utf8 as TU import qualified System.IO as IO #ifdef MIN_VERSION_tasty_inspection_testing @@ -107,6 +108,9 @@ tl_write_read_line m b t = write_read (TL.concat . take 1) TL.filter TL.hPutStrLn TL.hGetLine m b [t] +utf8_write_read = write_read T.unlines T.filter TU.hPutStr TU.hGetContents +utf8_write_read_line m b t = write_read (T.concat . take 1) T.filter TU.hPutStrLn + TU.hGetLine m b [t] testLowLevel :: TestTree testLowLevel = @@ -142,7 +146,9 @@ testProperty "t_write_read" t_write_read, testProperty "tl_write_read" tl_write_read, testProperty "t_write_read_line" t_write_read_line, - testProperty "tl_write_read_line" tl_write_read_line + testProperty "tl_write_read_line" tl_write_read_line, + testProperty "utf8_write_read" utf8_write_read, + testProperty "utf8_write_read_line" utf8_write_read_line -- These tests are subject to I/O race conditions -- testProperty "t_put_get" t_put_get, -- testProperty "tl_put_get" tl_put_get diff --git a/tests/Tests/QuickCheckUtils.hs b/tests/Tests/QuickCheckUtils.hs --- a/tests/Tests/QuickCheckUtils.hs +++ b/tests/Tests/QuickCheckUtils.hs @@ -2,8 +2,9 @@ -- instances, and comparison functions, so we can focus on the actual properties -- in the 'Tests.Properties' module. -- -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -213,11 +214,13 @@ arbitrary = arbitraryPrecision 22 shrink = map Precision . shrink . precision undefined +#if !MIN_VERSION_QuickCheck(2,14,3) instance Arbitrary IO.Newline where arbitrary = oneof [return IO.LF, return IO.CRLF] instance Arbitrary IO.NewlineMode where arbitrary = IO.NewlineMode <$> arbitrary <*> arbitrary +#endif instance Arbitrary IO.BufferMode where arbitrary = oneof [ return IO.NoBuffering, diff --git a/tests/Tests/RebindableSyntaxTest.hs b/tests/Tests/RebindableSyntaxTest.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/RebindableSyntaxTest.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE RebindableSyntax, TemplateHaskell #-} + +module Tests.RebindableSyntaxTest where + +import qualified Data.Text as Text +import Language.Haskell.TH.Syntax (lift) +import Test.Tasty.HUnit (testCase, assertEqual) +import Test.Tasty (TestTree, testGroup) +import Prelude (($)) + +tests :: TestTree +tests = testGroup "RebindableSyntax" + [ testCase "test" $ assertEqual "a" $(lift (Text.pack "a")) (Text.pack "a") + ] diff --git a/tests/Tests/Regressions.hs b/tests/Tests/Regressions.hs --- a/tests/Tests/Regressions.hs +++ b/tests/Tests/Regressions.hs @@ -11,7 +11,7 @@ ) where import Control.Exception (SomeException, handle) -import Data.Char (isLetter) +import Data.Char (isLetter, chr) import GHC.Exts (Int(..), sizeofByteArray#) import System.IO import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure) @@ -23,6 +23,8 @@ import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding.Error as E import qualified Data.Text.Internal as T +import qualified Data.Text.Internal.Lazy.Encoding.Fusion as E +import qualified Data.Text.Internal.Lazy.Fusion as LF import qualified Data.Text.IO as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as TB @@ -30,6 +32,7 @@ import qualified Data.Text.Unsafe as T import qualified Test.Tasty as F import qualified Test.Tasty.HUnit as F +import Test.Tasty.HUnit ((@?=)) import System.Directory (removeFile) import Tests.Utils (withTempFile) @@ -145,6 +148,34 @@ (decodeL (LB.fromChunks [B.pack [194], B.pack [97, 98, 99]])) (decodeL (LB.fromChunks [B.pack [194, 97, 98, 99]])) +-- Stream decoders should not loop on incomplete code points +t525 :: IO () +t525 = do + let decodeUtf8With onErr bs = LF.unstream (E.streamUtf8 onErr bs) + decodeUtf8With E.lenientDecode "\xC0" @?= "\65533" + LE.decodeUtf16BEWith E.lenientDecode "\0" @?= "\65533" + LE.decodeUtf16LEWith E.lenientDecode "\0" @?= "\65533" + LE.decodeUtf32BEWith E.lenientDecode "\0" @?= "\65533" + LE.decodeUtf32LEWith E.lenientDecode "\0" @?= "\65533" + +-- Stream decoders skip one invalid byte at a time +t528 :: IO () +t528 = do + let decodeUtf8With onErr bs = LF.unstream (E.streamUtf8 onErr bs) + decodeUtf8With E.lenientDecode "\xC0\xF0\x90\x80\x80" @?= "\65533\65536" + LE.decodeUtf16BEWith E.lenientDecode "\xD8\xD8\x00\xDC\x00" @?= "\65533\65536" + LE.decodeUtf16LEWith E.lenientDecode "\xD8\xD8\x00\xD8\x00\xDC" @?= "\65533\65533\65536" + LE.decodeUtf32BEWith E.lenientDecode "\xFF\x00\x00\x00\x00" @?= "\65533\0" + LE.decodeUtf32LEWith E.lenientDecode "\x00\x00\xFF\x00\x00" @?= "\65533\65280" + +t529 :: IO () +t529 = do + let decode = TE.decodeUtf8With E.lenientDecode + -- https://github.com/haskell/bytestring/issues/575 + assertEqual "Data.ByteString.isValidUtf8 should work correctly" + (T.pack (chr 33 : replicate 31 (chr 0) ++ [chr 65533, chr 0])) + (decode (B.pack (33 : replicate 31 0 ++ [128, 0]))) + tests :: F.TestTree tests = F.testGroup "Regressions" [ F.testCase "hGetContents_crash" hGetContents_crash @@ -159,4 +190,7 @@ , F.testCase "t280/singleton" t280_singleton , F.testCase "t301" t301 , F.testCase "t330" t330 + , F.testCase "t525" t525 + , F.testCase "t528" t528 + , F.testCase "t529" t529 ] diff --git a/text.cabal b/text.cabal --- a/text.cabal +++ b/text.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: text -version: 2.0.2 +version: 2.1 homepage: https://github.com/haskell/text bug-reports: https://github.com/haskell/text/issues @@ -52,8 +52,10 @@ GHC == 8.8.4 GHC == 8.10.7 GHC == 9.0.2 - GHC == 9.2.4 - GHC == 9.4.1 + GHC == 9.2.8 + GHC == 9.4.6 + GHC == 9.6.2 + GHC == 9.8.1 extra-source-files: -- scripts/CaseFolding.txt @@ -73,7 +75,7 @@ manual: True flag simdutf - description: use simdutf library + description: use simdutf library, causes Data.Text.Internal.Validate.Simd to be exposed default: True manual: True @@ -85,6 +87,7 @@ hs-source-dirs: src if flag(simdutf) + exposed-modules: Data.Text.Internal.Validate.Simd include-dirs: simdutf cxx-sources: simdutf/simdutf.cpp cbits/validate_utf8.cpp @@ -102,17 +105,12 @@ extra-libraries: stdc++ else extra-libraries: c++ c++abi - elif os(linux) - extra-libraries: stdc++ - else - -- This is supposed to be under arch(wasm32), but we can't do that yet - -- since cabal check would fail with unrecognized arch, see - -- https://github.com/haskell/cabal/pull/8096 for the fix. - -- TODO: when a new cabal release is out with that fix, bump cabal in CI - -- and add proper arch(wasm32) declaration here. + elif arch(wasm32) cpp-options: -DSIMDUTF_NO_THREADS cxx-options: -fno-exceptions extra-libraries: c++ c++abi + else + extra-libraries: stdc++ -- Certain version of GHC crash on Windows, when TemplateHaskell encounters C++. -- https://gitlab.haskell.org/ghc/ghc/-/issues/19417 @@ -143,6 +141,7 @@ Data.Text.Encoding.Error Data.Text.Foreign Data.Text.IO + Data.Text.IO.Utf8 Data.Text.Internal Data.Text.Internal.Builder Data.Text.Internal.Builder.Functions @@ -172,6 +171,7 @@ Data.Text.Internal.StrictBuilder Data.Text.Internal.Unsafe Data.Text.Internal.Unsafe.Char + Data.Text.Internal.Validate Data.Text.Lazy Data.Text.Lazy.Builder Data.Text.Lazy.Builder.Int @@ -190,11 +190,14 @@ array >= 0.3 && < 0.6, base >= 4.10 && < 5, binary >= 0.5 && < 0.9, - bytestring >= 0.10.4 && < 0.12, - deepseq >= 1.1 && < 1.5, - ghc-prim >= 0.2 && < 0.11, - template-haskell >= 2.5 && < 2.21 + bytestring >= 0.10.4 && < 0.13, + deepseq >= 1.1 && < 1.6, + ghc-prim >= 0.2 && < 0.12, + template-haskell >= 2.5 && < 2.22 + if impl(ghc < 9.4) + build-depends: data-array-byte >= 0.1 && < 0.2 + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 if flag(developer) ghc-options: -fno-ignore-asserts @@ -249,6 +252,7 @@ Tests.Properties.Text Tests.Properties.Transcoding Tests.QuickCheckUtils + Tests.RebindableSyntaxTest Tests.Regressions Tests.SlowFunctions Tests.Utils @@ -278,11 +282,7 @@ benchmark text-benchmarks type: exitcode-stdio-1.0 - ghc-options: -Wall -O2 -rtsopts - if impl(ghc >= 8.10) - ghc-options: "-with-rtsopts=-A32m --nonmoving-gc" - else - ghc-options: "-with-rtsopts=-A32m" + ghc-options: -Wall -O2 -rtsopts "-with-rtsopts=-A32m" if impl(ghc >= 8.6) ghc-options: -fproc-alignment=64