text 2.0.1 → 2.0.2
raw patch · 29 files changed
+1554/−364 lines, 29 filesdep ~basedep ~ghc-primdep ~template-haskell
Dependency ranges changed: base, ghc-prim, template-haskell
Files
- cbits/is_ascii.c +7/−0
- changelog.md +33/−0
- scripts/Arsec.hs +7/−2
- src/Data/Text.hs +149/−37
- src/Data/Text/Array.hs +3/−4
- src/Data/Text/Encoding.hs +123/−176
- src/Data/Text/Internal.hs +48/−6
- src/Data/Text/Internal/Builder.hs +1/−1
- src/Data/Text/Internal/ByteStringCompat.hs +0/−28
- src/Data/Text/Internal/Encoding.hs +531/−0
- src/Data/Text/Internal/Encoding/Fusion.hs +1/−1
- src/Data/Text/Internal/Encoding/Utf8.hs +8/−2
- src/Data/Text/Internal/Fusion/Common.hs +12/−3
- src/Data/Text/Internal/Lazy/Encoding/Fusion.hs +1/−1
- src/Data/Text/Internal/Lazy/Search.hs +2/−3
- src/Data/Text/Internal/Private.hs +1/−1
- src/Data/Text/Internal/Search.hs +2/−3
- src/Data/Text/Internal/StrictBuilder.hs +121/−0
- src/Data/Text/Lazy.hs +37/−7
- src/Data/Text/Lazy/Builder.hs +1/−1
- src/Data/Text/Lazy/Encoding.hs +10/−19
- src/Data/Text/Show.hs +20/−34
- tests/Tests/Properties/Basics.hs +3/−1
- tests/Tests/Properties/Folds.hs +13/−2
- tests/Tests/Properties/LowLevel.hs +3/−2
- tests/Tests/Properties/Substrings.hs +8/−4
- tests/Tests/Properties/Text.hs +75/−2
- tests/Tests/Properties/Transcoding.hs +315/−14
- text.cabal +19/−10
cbits/is_ascii.c view
@@ -45,3 +45,10 @@ return src - src0; }++/*+ _hs_text_is_ascii_offset is a helper for calling _hs_text_is_ascii on Texts.+*/+const size_t _hs_text_is_ascii_offset(const uint8_t *arr, size_t off, size_t len){+ return _hs_text_is_ascii(arr + off, arr + off + len);+}
changelog.md view
@@ -1,3 +1,36 @@+### 2.0.2++* [Add decoding functions in `Data.Text.Encoding` that allow+ more control for error handling and for how to allocate text](https://github.com/haskell/text/pull/448). Thanks to David Sledge!+ * `decodeASCIIPrefix`+ * `decodeUtf8Chunk`+ * `decodeUtf8More`+ * `Utf8ValidState`+ * `startUtf8ValidState`+ * `StrictBuilder`+ * `strictBuilderToText`+ * `textToStrictBuilder`+ * `validateUtf8Chunk`+ * `validateUtf8More`++* [Fix quadratic slowdown when decoding invalid UTF-8 bytestrings](https://github.com/haskell/text/issues/495)++* [Add `isAscii :: Text -> Bool`](https://github.com/haskell/text/issues/497)++* [Add `decodeASCII' :: ByteString -> Maybe Text`](https://github.com/haskell/text/issues/499)++* Add internal module `Data.Text.Internal.StrictBuilder`++* Add internal module `Data.Text.Internal.Encoding`++* Add `Data.Text.Internal.Encoding.Utf8.updateDecoderState` and export `utf8{Accept,Reject}State` from the same module.++* [Speed up case conversions](https://github.com/haskell/text/pull/460)++* [Reduce code bloat for literal strings](https://github.com/haskell/text/pull/468)++* [Remove support for GHC 8.0](https://github.com/haskell/text/pull/485)+ ### 2.0.1 * Improve portability of C and C++ code.
scripts/Arsec.hs view
@@ -15,10 +15,11 @@ , module Text.ParserCombinators.Parsec.Prim ) where +import Prelude hiding (head, tail) import Control.Monad import Control.Applicative import Data.Char-import Numeric+import Numeric (readHex, showHex) import Text.ParserCombinators.Parsec.Char hiding (lower, upper) import Text.ParserCombinators.Parsec.Combinator hiding (optional) import Text.ParserCombinators.Parsec.Error@@ -27,7 +28,11 @@ type Comment = String unichar :: Parser Char-unichar = chr . fst . head . readHex <$> many1 hexDigit+unichar = do+ digits <- many1 hexDigit+ case readHex digits of+ [] -> error "unichar: cannot parse hex digits"+ (hd, _) : _ -> pure $ chr hd unichars :: Parser [Char] unichars = manyTill (unichar <* spaces) semi
src/Data/Text.hs view
@@ -1,10 +1,12 @@-{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples, TypeFamilies #-}+{-# LANGUAGE BangPatterns, CPP, MagicHash, RankNTypes, UnboxedTuples, TypeFamilies #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE UnliftedFFITypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-} -- | -- Module : Data.Text@@ -108,6 +110,7 @@ , all , maximum , minimum+ , isAscii -- * Construction @@ -215,49 +218,52 @@ #if defined(ASSERTS) import Control.Exception (assert) #endif-import Data.Bits ((.&.))-import Data.Char (isSpace, isAscii, ord)+import Data.Bits ((.&.), shiftR, shiftL)+import qualified Data.Char as Char import Data.Data (Data(gfoldl, toConstr, gunfold, dataTypeOf), constrIndex, Constr, mkConstr, DataType, mkDataType, Fixity(Prefix)) import Control.Monad (foldM) import Control.Monad.ST (ST, runST) import Control.Monad.ST.Unsafe (unsafeIOToST) import qualified Data.Text.Array as A-import qualified Data.List as L+import qualified Data.List as L hiding (head, tail) import Data.Binary (Binary(get, put))-import Data.Int (Int8) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.String (IsString(..)) import Data.Text.Internal.Encoding.Utf8 (utf8Length, utf8LengthByLeader, chr2, chr3, chr4, ord2, ord3, ord4) import qualified Data.Text.Internal.Fusion as S+import Data.Text.Internal.Fusion.CaseMapping (foldMapping, lowerMapping, upperMapping) import qualified Data.Text.Internal.Fusion.Common as S import Data.Text.Encoding (decodeUtf8', encodeUtf8) import Data.Text.Internal.Fusion (stream, reverseStream, unstream) import Data.Text.Internal.Private (span_)-import Data.Text.Internal (Text(..), empty, firstf, mul, safe, text, append)+import Data.Text.Internal (Text(..), empty, firstf, mul, safe, text, append, pack) import Data.Text.Internal.Unsafe.Char (unsafeWrite, unsafeChr8) import Data.Text.Show (singleton, unpack, unpackCString#, unpackCStringAscii#) import qualified Prelude as P import Data.Text.Unsafe (Iter(..), iter, iter_, lengthWord8, reverseIter,- reverseIter_, unsafeHead, unsafeTail, unsafeDupablePerformIO, iterArray, reverseIterArray)-import Data.Text.Foreign (asForeignPtr)+ reverseIter_, unsafeHead, unsafeTail, iterArray, reverseIterArray) import Data.Text.Internal.Search (indices) #if defined(__HADDOCK__) import Data.ByteString (ByteString) import qualified Data.Text.Lazy as L-import Data.Int (Int64) #endif import Data.Word (Word8) import Foreign.C.Types import GHC.Base (eqInt, neInt, gtInt, geInt, ltInt, leInt, ByteArray#) import qualified GHC.Exts as Exts+import GHC.Int (Int8, Int64(..)) import GHC.Stack (HasCallStack) import qualified Language.Haskell.TH.Lib as TH import qualified Language.Haskell.TH.Syntax as TH import Text.Printf (PrintfArg, formatArg, formatString) import System.Posix.Types (CSsize(..))++#if MIN_VERSION_template_haskell(2,16,0)+import Data.Text.Foreign (asForeignPtr) import System.IO.Unsafe (unsafePerformIO)+#endif -- $setup -- >>> :set -package transformers@@ -411,7 +417,7 @@ instance TH.Lift Text where #if MIN_VERSION_template_haskell(2,16,0) lift txt = do- let (ptr, len) = unsafePerformIO $ asForeignPtr txt + 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) #else@@ -423,6 +429,7 @@ liftTyped = TH.unsafeTExpCoerce . TH.lift #endif +#if MIN_VERSION_template_haskell(2,16,0) unpackCStringLen# :: Exts.Addr# -> Int -> Text unpackCStringLen# addr# l = Text ba 0 l where@@ -431,6 +438,7 @@ A.copyFromPointer marr 0 (Exts.Ptr addr#) l A.unsafeFreeze marr {-# NOINLINE unpackCStringLen# #-} -- set as NOINLINE to avoid generated code bloat+#endif -- | @since 1.2.2.0 instance PrintfArg Text where@@ -451,18 +459,6 @@ -- of underlying bytearrays, no decoding is needed. -- -------------------------------------------------------------------------------- * Conversion to/from 'Text'---- | /O(n)/ Convert a 'String' into a 'Text'.--- Performs replacement on invalid scalar values, so @'unpack' . 'pack'@ is not 'id':------ >>> unpack (pack "\55555")--- "\65533"-pack :: String -> Text-pack = unstream . S.map safe . S.streamList-{-# INLINE [1] pack #-}---- ----------------------------------------------------------------------------- -- * Basic functions -- | /O(n)/ Adds a character to the front of a 'Text'. This function@@ -848,6 +844,84 @@ -- sensitivity should use appropriate versions of the -- <http://hackage.haskell.org/package/text-icu-0.6.3.7/docs/Data-Text-ICU.html#g:4 case mapping functions from the text-icu package >. +caseConvert :: (Word8 -> Word8) -> (Exts.Char# -> _ {- unboxed Int64 -}) -> Text -> Text+caseConvert ascii remap (Text src o l) = runST $ do+ -- Case conversion a single code point may produce up to 3 code-points,+ -- each up to 4 bytes, so 12 in total.+ dst <- A.new (l + 12)+ outer dst l o 0+ where+ outer :: forall s. A.MArray s -> Int -> Int -> Int -> ST s Text+ outer !dst !dstLen = inner+ where+ inner !srcOff !dstOff+ | srcOff >= o + l = do+ A.shrinkM dst dstOff+ arr <- A.unsafeFreeze dst+ return (Text arr 0 dstOff)+ | dstOff + 12 > dstLen = do+ -- Ensure to extend the buffer by at least 12 bytes.+ let !dstLen' = dstLen + max 12 (l + o - srcOff)+ dst' <- A.resizeM dst dstLen'+ outer dst' dstLen' srcOff dstOff+ -- If a character is to remain unchanged, no need to decode Char back into UTF8,+ -- just copy bytes from input.+ | otherwise = do+ let m0 = A.unsafeIndex src srcOff+ m1 = A.unsafeIndex src (srcOff + 1)+ m2 = A.unsafeIndex src (srcOff + 2)+ m3 = A.unsafeIndex src (srcOff + 3)+ !d = utf8LengthByLeader m0+ case d of+ 1 -> do+ A.unsafeWrite dst dstOff (ascii m0)+ inner (srcOff + 1) (dstOff + 1)+ 2 -> do+ let !(Exts.C# c) = chr2 m0 m1+ dstOff' <- case I64# (remap c) of+ 0 -> do+ A.unsafeWrite dst dstOff m0+ A.unsafeWrite dst (dstOff + 1) m1+ pure $ dstOff + 2+ i -> writeMapping i dstOff+ inner (srcOff + 2) dstOff'+ 3 -> do+ let !(Exts.C# c) = chr3 m0 m1 m2+ dstOff' <- case I64# (remap c) of+ 0 -> do+ A.unsafeWrite dst dstOff m0+ A.unsafeWrite dst (dstOff + 1) m1+ A.unsafeWrite dst (dstOff + 2) m2+ pure $ dstOff + 3+ i -> writeMapping i dstOff+ inner (srcOff + 3) dstOff'+ _ -> do+ let !(Exts.C# c) = chr4 m0 m1 m2 m3+ dstOff' <- case I64# (remap c) of+ 0 -> do+ A.unsafeWrite dst dstOff m0+ A.unsafeWrite dst (dstOff + 1) m1+ A.unsafeWrite dst (dstOff + 2) m2+ A.unsafeWrite dst (dstOff + 3) m3+ pure $ dstOff + 4+ i -> writeMapping i dstOff+ inner (srcOff + 4) dstOff'++ writeMapping :: Int64 -> Int -> ST s Int+ writeMapping 0 dstOff = pure dstOff+ writeMapping i dstOff = do+ let (ch, j) = chopOffChar i+ d <- unsafeWrite dst dstOff ch+ writeMapping j (dstOff + d)++ chopOffChar :: Int64 -> (Char, Int64)+ chopOffChar ab = (chr a, ab `shiftR` 21)+ where+ chr (Exts.I# n) = Exts.C# (Exts.chr# n)+ mask = (1 `shiftL` 21) - 1+ a = P.fromIntegral $ ab .&. mask+{-# INLINE caseConvert #-}+ -- | /O(n)/ Convert a string to folded case. -- -- This function is mainly useful for performing caseless (also known@@ -865,7 +939,7 @@ -- U+00B5) is case folded to \"μ\" (small letter mu, U+03BC) -- instead of itself. toCaseFold :: Text -> Text-toCaseFold t = unstream (S.toCaseFold (stream t))+toCaseFold = \xs -> caseConvert (\w -> if w - 65 <= 25 then w + 32 else w) foldMapping xs {-# INLINE toCaseFold #-} -- | /O(n)/ Convert a string to lower case, using simple case@@ -876,7 +950,7 @@ -- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069) -- followed by \" ̇\" (combining dot above, U+0307). toLower :: Text -> Text-toLower t = unstream (S.toLower (stream t))+toLower = \xs -> caseConvert (\w -> if w - 65 <= 25 then w + 32 else w) lowerMapping xs {-# INLINE toLower #-} -- | /O(n)/ Convert a string to upper case, using simple case@@ -886,17 +960,26 @@ -- instance, the German \"ß\" (eszett, U+00DF) maps to the -- two-letter sequence \"SS\". toUpper :: Text -> Text-toUpper t = unstream (S.toUpper (stream t))+toUpper = \xs -> caseConvert (\w -> if w - 97 <= 25 then w - 32 else w) upperMapping xs {-# INLINE toUpper #-} -- | /O(n)/ Convert a string to title case, using simple case -- conversion. ----- The first letter of the input is converted to title case, as is+-- The first letter (as determined by 'Data.Char.isLetter')+-- of the input is converted to title case, as is -- every subsequent letter that immediately follows a non-letter. -- Every letter that immediately follows another letter is converted -- to lower case. --+-- This function is not idempotent.+-- Consider lower-case letter @ʼn@ (U+0149 LATIN SMALL LETTER N PRECEDED BY APOSTROPHE).+-- Then 'T.toTitle' @"ʼn"@ = @"ʼN"@: the first (and the only) letter of the input+-- is converted to title case, becoming two letters.+-- Now @ʼ@ (U+02BC MODIFIER LETTER APOSTROPHE) is a modifier letter+-- and as such is recognised as a letter by 'Data.Char.isLetter',+-- so 'T.toTitle' @"ʼN"@ = @"'n"@.+-- -- The result string may be longer than the input string. For example, -- the Latin small ligature fl (U+FB02) is converted to the -- sequence Latin capital letter F (U+0046) followed by Latin small@@ -1094,6 +1177,35 @@ minimum t = S.minimum (stream t) {-# INLINE minimum #-} +-- | \O(n)\ Test whether 'Text' contains only ASCII code-points (i.e. only+-- U+0000 through U+007F).+--+-- This is a more efficient version of @'all' 'Data.Char.isAscii'@.+--+-- >>> isAscii ""+-- True+--+-- >>> isAscii "abc\NUL"+-- True+--+-- >>> isAscii "abcd€"+-- False+--+-- prop> isAscii t == all (< '\x80') t+--+-- @since 2.0.2+isAscii :: Text -> Bool+isAscii (Text (A.ByteArray arr) off len) =+ cSizeToInt (c_is_ascii_offset arr (intToCSize off) (intToCSize len)) == len+{-# INLINE isAscii #-}++cSizeToInt :: CSize -> Int+cSizeToInt = P.fromIntegral+{-# INLINE cSizeToInt #-}++foreign import ccall unsafe "_hs_text_is_ascii_offset" c_is_ascii_offset+ :: ByteArray# -> CSize -> CSize -> CSize+ -- ----------------------------------------------------------------------------- -- * Building 'Text's -- | /O(n)/ 'scanl' is similar to 'foldl', but returns a list of@@ -1233,8 +1345,8 @@ replicateChar :: Int -> Char -> Text replicateChar !len !c' | len <= 0 = empty- | isAscii c = runST $ do- marr <- A.newFilled len (ord c)+ | Char.isAscii c = runST $ do+ marr <- A.newFilled len (Char.ord c) arr <- A.unsafeFreeze marr return $ Text arr 0 len | otherwise = runST $ do@@ -1294,13 +1406,13 @@ -- @since 2.0 measureOff :: Int -> Text -> Int measureOff !n (Text (A.ByteArray arr) off len) = if len == 0 then 0 else- cSsizeToInt $ unsafeDupablePerformIO $+ cSsizeToInt $ c_measure_off arr (intToCSize off) (intToCSize len) (intToCSize n) -- | The input buffer (arr :: ByteArray#, off :: CSize, len :: CSize) -- must specify a valid UTF-8 sequence, this condition is not checked. foreign import ccall unsafe "_hs_text_measure_off" c_measure_off- :: ByteArray# -> CSize -> CSize -> CSize -> IO CSsize+ :: ByteArray# -> CSize -> CSize -> CSize -> CSsize -- | /O(n)/ 'takeEnd' @n@ @t@ returns the suffix remaining after -- taking @n@ characters from the end of @t@.@@ -1417,14 +1529,14 @@ -- -- > dropWhile isSpace stripStart :: Text -> Text-stripStart = dropWhile isSpace+stripStart = dropWhile Char.isSpace {-# INLINE stripStart #-} -- | /O(n)/ Remove trailing white space from a string. Equivalent to: -- -- > dropWhileEnd isSpace stripEnd :: Text -> Text-stripEnd = dropWhileEnd isSpace+stripEnd = dropWhileEnd Char.isSpace {-# INLINE [1] stripEnd #-} -- | /O(n)/ Remove leading and trailing white space from a string.@@ -1432,7 +1544,7 @@ -- -- > dropAround isSpace strip :: Text -> Text-strip = dropAround isSpace+strip = dropAround Char.isSpace {-# INLINE [1] strip #-} -- | /O(n)/ 'splitAt' @n t@ returns a pair whose first element is a@@ -1912,7 +2024,7 @@ | w0 < 0xE0 = loop start (n + 2) -- or 3 bytes for 0x1680 + 0x2000..0x200A + 0x2028..0x2029 + 0x202F + 0x205F + 0x3000 | w0 == 0xE1 && w1 == 0x9A && w2 == 0x80- || w0 == 0xE2 && (w1 == 0x80 && isSpace (chr3 w0 w1 w2) || w1 == 0x81 && w2 == 0x9F)+ || w0 == 0xE2 && (w1 == 0x80 && Char.isSpace (chr3 w0 w1 w2) || w1 == 0x81 && w2 == 0x9F) || w0 == 0xE3 && w1 == 0x80 && w2 == 0x80 = if start == n then loop (n + 3) (n + 3)@@ -1941,12 +2053,12 @@ | delta < 0 = [Text arr n (len + off - n)] | otherwise = Text arr n delta : go (n + delta + 1) where- delta = cSsizeToInt $ unsafeDupablePerformIO $+ delta = cSsizeToInt $ memchr arr# (intToCSize n) (intToCSize (len + off - n)) 0x0A {-# INLINE lines #-} foreign import ccall unsafe "_hs_text_memchr" memchr- :: ByteArray# -> CSize -> CSize -> Word8 -> IO CSsize+ :: ByteArray# -> CSize -> CSize -> Word8 -> CSsize -- | /O(n)/ Joins lines, after appending a terminating newline to -- each.@@ -2123,7 +2235,7 @@ return marr ord8 :: Char -> Word8-ord8 = P.fromIntegral . ord+ord8 = P.fromIntegral . Char.ord intToCSize :: Int -> CSize intToCSize = P.fromIntegral
src/Data/Text/Array.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types,+{-# LANGUAGE BangPatterns, CPP, MagicHash, RankNTypes, RecordWildCards, UnboxedTuples, UnliftedFFITypes #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} -- |@@ -53,7 +53,6 @@ import GHC.Stack (HasCallStack) #endif #if !MIN_VERSION_base(4,11,0)-import Data.Text.Internal.Unsafe (inlinePerformIO) import Foreign.C.Types (CInt(..)) #endif import GHC.Exts hiding (toList)@@ -322,9 +321,9 @@ #if MIN_VERSION_base(4,11,0) i = I# (compareByteArrays# src1# off1# src2# off2# count#) #else- i = fromIntegral (inlinePerformIO (memcmp src1# off1# src2# off2# count#))+ i = fromIntegral (memcmp src1# off1# src2# off2# count#) foreign import ccall unsafe "_hs_text_memcmp2" memcmp- :: ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> IO CInt+ :: ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> CInt #endif {-# INLINE compareInternal #-}
src/Data/Text/Encoding.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Text.Encoding -- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan,@@ -29,10 +28,10 @@ -- ** Total Functions #total# -- $total decodeLatin1+ , decodeASCIIPrefix , decodeUtf8Lenient-- -- *** Catchable failure , decodeUtf8'+ , decodeASCII' -- *** Controllable error handling , decodeUtf8With@@ -46,6 +45,16 @@ , streamDecodeUtf8With , Decoding(..) + -- *** Incremental UTF-8 decoding+ -- $incremental+ , decodeUtf8Chunk+ , decodeUtf8More+ , Utf8State+ , startUtf8State+ , StrictBuilder+ , strictBuilderToText+ , textToStrictBuilder+ -- ** Partial Functions -- $partial , decodeASCII@@ -68,48 +77,47 @@ -- * Encoding Text using ByteString Builders , encodeUtf8Builder , encodeUtf8BuilderEscaped- ) where -import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)+ -- * ByteString validation+ -- $validation+ , validateUtf8Chunk+ , validateUtf8More+ ) where import Control.Exception (evaluate, try)-import Control.Monad.ST (runST, ST)+import Control.Monad.ST (runST)+import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO) import Data.Bits (shiftR, (.&.))-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Short.Internal as SBS-import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode, lenientDecode)-import Data.Text.Internal (Text(..), safe, empty, append)-import Data.Text.Internal.Unsafe (unsafeWithForeignPtr)-import Data.Text.Internal.Unsafe.Char (unsafeWrite)-import Data.Text.Show as T (singleton)-import Data.Text.Unsafe (unsafeDupablePerformIO) import Data.Word (Word8) import Foreign.C.Types (CSize(..)) import Foreign.Ptr (Ptr, minusPtr, plusPtr) import Foreign.Storable (poke, peekByteOff) import GHC.Exts (byteArrayContents#, unsafeCoerce#) import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(PlainPtr))+import Data.ByteString (ByteString)+import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode, lenientDecode)+import Data.Text.Internal (Text(..), empty)+import Data.Text.Internal.ByteStringCompat (withBS)+import Data.Text.Internal.Encoding+import Data.Text.Internal.Unsafe (unsafeWithForeignPtr)+import Data.Text.Unsafe (unsafeDupablePerformIO)+import Data.Text.Show ()+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Builder.Internal as B hiding (empty, append) import qualified Data.ByteString.Builder.Prim as BP import qualified Data.ByteString.Builder.Prim.Internal as BP-import Data.Text.Internal.Encoding.Utf8 (utf8DecodeStart, utf8DecodeContinue, DecoderResult(..))+import qualified Data.ByteString.Short.Internal as SBS import qualified Data.Text.Array as A import qualified Data.Text.Internal.Encoding.Fusion as E import qualified Data.Text.Internal.Fusion as F-import Data.Text.Internal.ByteStringCompat #if defined(ASSERTS) import GHC.Stack (HasCallStack) #endif -#ifdef SIMDUTF-import Foreign.C.Types (CInt(..))-#elif !MIN_VERSION_bytestring(0,11,2)-import qualified Data.ByteString.Unsafe as B-import Data.Text.Internal.Encoding.Utf8 (CodePoint(..))-#endif+-- $validation+-- These functions are for validating 'ByteString's as encoded text. -- $strict --@@ -135,20 +143,68 @@ -- (preferably not at all). See "Data.Text.Encoding#g:total" for better -- solutions. --- | Decode a 'ByteString' containing 7-bit ASCII--- encoded text.+-- | Decode a 'ByteString' containing ASCII text. --+-- This is a total function which returns a pair of the longest ASCII prefix+-- as 'Text', and the remaining suffix as 'ByteString'.+--+-- Important note: the pair is lazy. This lets you check for errors by testing+-- whether the second component is empty, without forcing the first component+-- (which does a copy).+-- To drop references to the input bytestring, force the prefix+-- (using 'seq' or @BangPatterns@) and drop references to the suffix.+--+-- === Properties+--+-- - If @(prefix, suffix) = decodeAsciiPrefix s@, then @'encodeUtf8' prefix <> suffix = s@.+-- - Either @suffix@ is empty, or @'B.head' suffix > 127@.+--+-- @since 2.0.2+decodeASCIIPrefix :: ByteString -> (Text, ByteString)+decodeASCIIPrefix bs = if B.null bs+ then (empty, B.empty)+ else+ let len = asciiPrefixLength bs+ prefix =+ let !(SBS.SBS arr) = SBS.toShort (B.take len bs) in+ Text (A.ByteArray arr) 0 len+ suffix = B.drop len bs in+ (prefix, suffix)+{-# INLINE decodeASCIIPrefix #-}++-- | Length of the longest ASCII prefix.+asciiPrefixLength :: ByteString -> Int+asciiPrefixLength bs = unsafeDupablePerformIO $ withBS bs $ \ fp len ->+ unsafeWithForeignPtr fp $ \src -> do+ fromIntegral <$> c_is_ascii src (src `plusPtr` len)++-- | Decode a 'ByteString' containing 7-bit ASCII encoded text.+--+-- This is a total function which returns either the 'ByteString' converted to a+-- 'Text' containing ASCII text, or 'Nothing'.+--+-- Use 'decodeASCIIPrefix' to retain the longest ASCII prefix for an invalid+-- input instead of discarding it.+--+-- @since 2.0.2+decodeASCII' :: ByteString -> Maybe Text+decodeASCII' bs =+ let (prefix, suffix) = decodeASCIIPrefix bs in+ if B.null suffix then Just prefix else Nothing+{-# INLINE decodeASCII' #-}++-- | Decode a 'ByteString' containing 7-bit ASCII encoded text.+-- -- This is a partial function: it checks that input does not contain -- anything except ASCII and copies buffer or throws an error otherwise.--- decodeASCII :: ByteString -> Text-decodeASCII bs = withBS bs $ \fp len -> if len == 0 then empty else runST $ do- asciiPrefixLen <- fmap cSizeToInt $ unsafeIOToST $ unsafeWithForeignPtr fp $ \src ->- c_is_ascii src (src `plusPtr` len)- if asciiPrefixLen == len- then let !(SBS.SBS arr) = SBS.toShort bs in- return (Text (A.ByteArray arr) 0 len)- else error $ "decodeASCII: detected non-ASCII codepoint at " ++ show asciiPrefixLen+decodeASCII bs =+ let (prefix, suffix) = decodeASCIIPrefix bs in+ case B.uncons suffix of+ Nothing -> prefix+ Just (word, _) ->+ let !errPos = B.length bs - B.length suffix in+ error $ "decodeASCII: detected non-ASCII codepoint " ++ show word ++ " at position " ++ show errPos -- | Decode a 'ByteString' containing Latin-1 (aka ISO-8859-1) encoded text. --@@ -166,7 +222,7 @@ decodeLatin1 bs = withBS bs $ \fp len -> runST $ do dst <- A.new (2 * len) let inner srcOff dstOff = if srcOff >= len then return dstOff else do- asciiPrefixLen <- fmap cSizeToInt $ unsafeIOToST $ unsafeWithForeignPtr fp $ \src ->+ asciiPrefixLen <- fmap fromIntegral $ unsafeIOToST $ unsafeWithForeignPtr fp $ \src -> c_is_ascii (src `plusPtr` srcOff) (src `plusPtr` len) if asciiPrefixLen == 0 then do@@ -178,7 +234,6 @@ unsafeIOToST $ unsafeWithForeignPtr fp $ \src -> unsafeSTToIO $ A.copyFromPointer dst dstOff (src `plusPtr` srcOff) asciiPrefixLen inner (srcOff + asciiPrefixLen) (dstOff + asciiPrefixLen)- actualLen <- inner 0 0 dst' <- A.resizeM dst actualLen arr <- A.unsafeFreeze dst'@@ -187,135 +242,6 @@ foreign import ccall unsafe "_hs_text_is_ascii" c_is_ascii :: Ptr Word8 -> Ptr Word8 -> IO CSize -isValidBS :: ByteString -> Bool-#ifdef SIMDUTF-isValidBS bs = withBS bs $ \fp len -> unsafeDupablePerformIO $- unsafeWithForeignPtr fp $ \ptr -> (/= 0) <$> c_is_valid_utf8 ptr (fromIntegral len)-#else-#if MIN_VERSION_bytestring(0,11,2)-isValidBS = B.isValidUtf8-#else-isValidBS 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---- | Decode a 'ByteString' containing UTF-8 encoded text.------ Surrogate code points in replacement character returned by 'OnDecodeError'--- will be automatically remapped to the replacement char @U+FFFD@.-decodeUtf8With ::-#if defined(ASSERTS)- HasCallStack =>-#endif- OnDecodeError -> ByteString -> Text-decodeUtf8With onErr bs- | isValidBS bs =- let !(SBS.SBS arr) = SBS.toShort bs in- (Text (A.ByteArray arr) 0 (B.length bs))- | B.null undecoded = txt- | otherwise = txt `append` (case onErr desc (Just (B.head undecoded)) of- Nothing -> txt'- Just c -> T.singleton c `append` txt')- where- (txt, undecoded) = decodeUtf8With2 onErr mempty bs- txt' = decodeUtf8With onErr (B.tail undecoded)- desc = "Data.Text.Internal.Encoding: Invalid UTF-8 stream"---- | Decode two consecutive bytestrings, returning Text and undecoded remainder.-decodeUtf8With2 ::-#if defined(ASSERTS)- HasCallStack =>-#endif- OnDecodeError -> ByteString -> ByteString -> (Text, ByteString)-decodeUtf8With2 onErr bs1@(B.length -> len1) bs2@(B.length -> len2) = runST $ do- marr <- A.new len'- outer marr len' 0 0- where- len = len1 + len2- len' = len + 4-- index i- | i < len1 = B.index bs1 i- | otherwise = B.index bs2 (i - len1)-- -- We need Data.ByteString.findIndexEnd, but it is unavailable before bytestring-0.10.12.0- guessUtf8Boundary :: Int- guessUtf8Boundary- | len2 >= 1 && w0 < 0x80 = len2 -- last char is ASCII- | len2 >= 1 && w0 >= 0xC0 = len2 - 1 -- last char starts a code point- | len2 >= 2 && w1 >= 0xC0 = len2 - 2 -- pre-last char starts a code point- | len2 >= 3 && w2 >= 0xC0 = len2 - 3- | len2 >= 4 && w3 >= 0xC0 = len2 - 4- | otherwise = 0- where- w0 = B.index bs2 (len2 - 1)- w1 = B.index bs2 (len2 - 2)- w2 = B.index bs2 (len2 - 3)- w3 = B.index bs2 (len2 - 4)-- decodeFrom :: Int -> DecoderResult- decodeFrom off = step (off + 1) (utf8DecodeStart (index off))- where- step i (Incomplete a b)- | i < len = step (i + 1) (utf8DecodeContinue (index i) a b)- step _ st = st-- outer :: forall s. A.MArray s -> Int -> Int -> Int -> ST s (Text, ByteString)- outer dst dstLen = inner- where- inner srcOff dstOff- | srcOff >= len = do- A.shrinkM dst dstOff- arr <- A.unsafeFreeze dst- return (Text arr 0 dstOff, mempty)-- | srcOff >= len1- , srcOff < len1 + guessUtf8Boundary- , dstOff + (len1 + guessUtf8Boundary - srcOff) <= dstLen- , bs <- B.drop (srcOff - len1) (B.take guessUtf8Boundary bs2)- , isValidBS bs = do- withBS bs $ \fp _ -> unsafeIOToST $ unsafeWithForeignPtr fp $ \src ->- unsafeSTToIO $ A.copyFromPointer dst dstOff src (len1 + guessUtf8Boundary - srcOff)- inner (len1 + guessUtf8Boundary) (dstOff + (len1 + guessUtf8Boundary - srcOff))-- | dstOff + 4 > dstLen = do- let dstLen' = dstLen + 4- dst' <- A.resizeM dst dstLen'- outer dst' dstLen' srcOff dstOff-- | otherwise = case decodeFrom srcOff of- Accept c -> do- d <- unsafeWrite dst dstOff c- inner (srcOff + d) (dstOff + d)- Reject -> case onErr desc (Just (index srcOff)) of- Nothing -> inner (srcOff + 1) dstOff- Just c -> do- d <- unsafeWrite dst dstOff (safe c)- inner (srcOff + 1) (dstOff + d)- Incomplete{} -> do- A.shrinkM dst dstOff- arr <- A.unsafeFreeze dst- let bs = if srcOff >= len1- then B.drop (srcOff - len1) bs2- else B.drop srcOff (bs1 `B.append` bs2)- return (Text arr 0 dstOff, bs)-- desc = "Data.Text.Internal.Encoding: Invalid UTF-8 stream"- -- $stream -- -- The 'streamDecodeUtf8' and 'streamDecodeUtf8With' functions accept@@ -406,12 +332,26 @@ HasCallStack => #endif OnDecodeError -> ByteString -> Decoding-streamDecodeUtf8With onErr = go mempty+streamDecodeUtf8With onErr = loop startUtf8State where- go bs1 bs2 = Some txt undecoded (go undecoded)- where- (txt, undecoded) = decodeUtf8With2 onErr bs1 bs2+ loop s chunk =+ let (builder, undecoded, s') = decodeUtf8With2 onErr invalidUtf8Msg s chunk+ in Some (strictBuilderToText builder) undecoded (loop s') +-- | Decode a 'ByteString' containing UTF-8 encoded text.+--+-- Surrogate code points in replacement character returned by 'OnDecodeError'+-- will be automatically remapped to the replacement char @U+FFFD@.+decodeUtf8With ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ OnDecodeError -> ByteString -> Text+decodeUtf8With onErr = decodeUtf8With1 onErr invalidUtf8Msg++invalidUtf8Msg :: String+invalidUtf8Msg = "Data.Text.Encoding: Invalid UTF-8 stream"+ -- | Decode a 'ByteString' containing UTF-8 encoded text that is known -- to be valid. --@@ -613,10 +553,17 @@ encodeUtf32BE txt = E.unstream (E.restreamUtf32BE (F.stream txt)) {-# INLINE encodeUtf32BE #-} -cSizeToInt :: CSize -> Int-cSizeToInt = fromIntegral--#ifdef SIMDUTF-foreign import ccall unsafe "_hs_text_is_valid_utf8" c_is_valid_utf8- :: Ptr Word8 -> CSize -> IO CInt-#endif+-- $incremental+-- The functions 'decodeUtf8Chunk' and 'decodeUtf8More' provide more+-- control for error-handling and streaming.+--+-- - Those functions return an UTF-8 prefix of the given 'ByteString' up to the next error.+-- For example this lets you insert or delete arbitrary text, or do some+-- stateful operations before resuming, such as keeping track of error locations.+-- In contrast, the older stream-oriented interface only lets you substitute+-- a single fixed 'Char' for each invalid byte in 'OnDecodeError'.+-- - That prefix is encoded as a 'StrictBuilder', so you can accumulate chunks+-- before doing the copying work to construct a 'Text', or you can+-- output decoded fragments immediately as a lazy 'Data.Text.Lazy.Text'.+--+-- For even lower-level primitives, see 'validateUtf8Chunk' and 'validateUtf8More'.
src/Data/Text/Internal.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE CPP, DeriveDataTypeable, UnboxedTuples #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} -- |@@ -42,24 +46,26 @@ , mul64 -- * Debugging , showText+ -- * Conversions+ , pack ) where #if defined(ASSERTS) import Control.Exception (assert) import GHC.Stack (HasCallStack) #endif-import Control.Monad.ST (ST)+import Control.Monad.ST (ST, runST) import Data.Bits import Data.Int (Int32, Int64)-import Data.Text.Internal.Unsafe.Char (ord)+import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite) import Data.Typeable (Typeable) import qualified Data.Text.Array as A -- | A space efficient, packed, unboxed Unicode text type. data Text = Text- {-# UNPACK #-} !A.Array -- bytearray encoded as UTF-8- {-# UNPACK #-} !Int -- offset in bytes (not in Char!), pointing to a start of UTF-8 sequence- {-# UNPACK #-} !Int -- length in bytes (not in Char!), pointing to an end of UTF-8 sequence+ {-# UNPACK #-} !A.Array -- ^ bytearray encoded as UTF-8+ {-# UNPACK #-} !Int -- ^ offset in bytes (not in Char!), pointing to a start of UTF-8 sequence+ {-# UNPACK #-} !Int -- ^ length in bytes (not in Char!), pointing to an end of UTF-8 sequence deriving (Typeable) -- | Smart constructor.@@ -231,3 +237,39 @@ -- -- * Offset and length must point to a valid UTF-8 sequence of bytes. -- Violation of this may cause memory access violation and divergence.++-- -----------------------------------------------------------------------------+-- * Conversion to/from 'Text'++-- | /O(n)/ Convert a 'String' into a 'Text'.+-- Performs replacement on invalid scalar values, so @'Data.Text.unpack' . 'pack'@ is not 'id':+--+-- >>> Data.Text.unpack (pack "\55555")+-- "\65533"+pack :: String -> Text+pack xs = runST $ do+ -- It's tempting to allocate a buffer of 4 * length xs bytes,+ -- but not only it's wasteful for predominantly ASCII arguments,+ -- the computation of length xs would force allocation of the entire xs at once.+ let dstLen = 64+ dst <- A.new dstLen+ outer dst dstLen 0 xs+ where+ outer :: forall s. A.MArray s -> Int -> Int -> String -> ST s Text+ outer !dst !dstLen = inner+ where+ inner !dstOff [] = do+ A.shrinkM dst dstOff+ arr <- A.unsafeFreeze dst+ return (Text arr 0 dstOff)+ inner !dstOff ccs@(c : cs)+ -- Each 'Char' takes up to 4 bytes+ | dstOff + 4 > dstLen = do+ -- Double size of the buffer+ let !dstLen' = dstLen * 2+ dst' <- A.resizeM dst dstLen'+ outer dst' dstLen' dstOff ccs+ | otherwise = do+ d <- unsafeWrite dst dstOff (safe c)+ inner (dstOff + d) cs+{-# NOINLINE [0] pack #-}
src/Data/Text/Internal/Builder.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}+{-# LANGUAGE BangPatterns, CPP, RankNTypes #-} {-# OPTIONS_HADDOCK not-home #-} -----------------------------------------------------------------------------
src/Data/Text/Internal/ByteStringCompat.hs view
@@ -8,14 +8,8 @@ import Foreign.ForeignPtr (ForeignPtr) #if !MIN_VERSION_bytestring(0,11,0)-#if MIN_VERSION_base(4,10,0) import GHC.ForeignPtr (plusForeignPtr)-#else-import GHC.ForeignPtr (ForeignPtr(ForeignPtr))-import GHC.Types (Int (..))-import GHC.Prim (plusAddr#) #endif-#endif mkBS :: ForeignPtr Word8 -> Int -> ByteString #if MIN_VERSION_bytestring(0,11,0)@@ -32,25 +26,3 @@ withBS (PS !sfp !soff !slen) kont = kont (plusForeignPtr sfp soff) slen #endif {-# INLINE withBS #-}--#if !MIN_VERSION_bytestring(0,11,0)-#if !MIN_VERSION_base(4,10,0)--- |Advances the given address by the given offset in bytes.------ The new 'ForeignPtr' shares the finalizer of the original,--- equivalent from a finalization standpoint to just creating another--- reference to the original. That is, the finalizer will not be--- called before the new 'ForeignPtr' is unreachable, nor will it be--- called an additional time due to this call, and the finalizer will--- be called with the same address that it would have had this call--- not happened, *not* the new address.-plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b-plusForeignPtr (ForeignPtr addr guts) (I# offset) = ForeignPtr (plusAddr# addr offset) guts-{-# INLINE [0] plusForeignPtr #-}-{-# RULES-"ByteString plusForeignPtr/0" forall fp .- plusForeignPtr fp 0 = fp- #-}-#endif-#endif-
+ src/Data/Text/Internal/Encoding.hs view
@@ -0,0 +1,531 @@+{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, MagicHash,+ UnliftedFFITypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Data.Text.Internal.Builder+-- License : BSD-style (see LICENSE)+-- Stability : experimental+--+-- /Warning/: this is an internal module, and does not have a stable+-- API or name. Functions in this module may not check or enforce+-- preconditions expected by public modules. Use at your own risk!+--+-- Internals of "Data.Text.Encoding".+--+-- @since 2.0.2+module Data.Text.Internal.Encoding+ ( validateUtf8Chunk+ , validateUtf8More+ , decodeUtf8Chunk+ , decodeUtf8More+ , decodeUtf8With1+ , decodeUtf8With2+ , Utf8State+ , startUtf8State+ , StrictBuilder()+ , strictBuilderToText+ , textToStrictBuilder++ -- * Internal+ , skipIncomplete+ , getCompleteLen+ , getPartialUtf8+ ) where++#if defined(ASSERTS)+import Control.Exception (assert)+#endif+import Data.Bits ((.&.), shiftL, shiftR)+import Data.ByteString (ByteString)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup(..))+#endif+import Data.Word (Word32, Word8)+import Foreign.Storable (pokeElemOff)+import Data.Text.Encoding.Error (OnDecodeError)+import Data.Text.Internal (Text(..))+import Data.Text.Internal.Encoding.Utf8+ (DecoderState, utf8AcceptState, utf8RejectState, updateDecoderState)+import Data.Text.Internal.StrictBuilder (StrictBuilder)+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as BI+import qualified Data.ByteString.Short.Internal as SBS+import qualified Data.Text.Array as A+import qualified Data.Text.Internal.StrictBuilder as SB+#if defined(ASSERTS)+import GHC.Stack (HasCallStack)+#endif++#ifdef SIMDUTF+import Data.Text.Internal.ByteStringCompat (withBS)+import Data.Text.Internal.Unsafe (unsafeWithForeignPtr)+import Data.Text.Unsafe (unsafeDupablePerformIO)+import Foreign.C.Types (CSize(..))+import Foreign.C.Types (CInt(..))+import Foreign.Ptr (Ptr)+#endif++-- | Use 'StrictBuilder' to build 'Text'.+--+-- @since 2.0.2+strictBuilderToText :: StrictBuilder -> Text+strictBuilderToText = SB.toText++-- | Copy 'Text' in a 'StrictBuilder'+--+-- @since 2.0.2+textToStrictBuilder :: Text -> StrictBuilder+textToStrictBuilder = SB.fromText++-- | State of decoding a 'ByteString' in UTF-8.+-- Enables incremental decoding ('validateUtf8Chunk', 'validateUtf8More',+-- 'decodeUtf8Chunk', 'decodeUtf8More').+--+-- @since 2.0.2++-- Internal invariant:+-- the first component is the initial state if and only if+-- the second component is empty.+--+-- @+-- 'utf9CodePointState' s = 'utf8StartState'+-- <=>+-- 'partialUtf8CodePoint' s = 'PartialUtf8CodePoint' 0+-- @+data Utf8State = Utf8State+ { -- | State of the UTF-8 state machine.+ utf8CodePointState :: {-# UNPACK #-} !DecoderState+ -- | Bytes of the currently incomplete code point (if any).+ , partialUtf8CodePoint :: {-# UNPACK #-} !PartialUtf8CodePoint+ }+ deriving (Eq, Show)++-- | Initial 'Utf8State'.+--+-- @since 2.0.2+startUtf8State :: Utf8State+startUtf8State = Utf8State utf8AcceptState partUtf8Empty++-- | Prefix of a UTF-8 code point encoded in 4 bytes,+-- possibly empty.+--+-- - The most significant byte contains the number of bytes,+-- between 0 and 3.+-- - The remaining bytes hold the incomplete code point.+-- - Unused bytes must be 0.+--+-- All of operations available on it are the functions below.+-- The constructor should never be used outside of those.+--+-- @since 2.0.2+newtype PartialUtf8CodePoint = PartialUtf8CodePoint Word32+ deriving (Eq, Show)++-- | Empty prefix.+partUtf8Empty :: PartialUtf8CodePoint+partUtf8Empty = PartialUtf8CodePoint 0++-- | Length of the partial code point, stored in the most significant byte.+partUtf8Len :: PartialUtf8CodePoint -> Int+partUtf8Len (PartialUtf8CodePoint w) = fromIntegral $ w `shiftR` 24++-- | Length of the code point once completed (it is known in the first byte).+-- 0 if empty.+partUtf8CompleteLen :: PartialUtf8CodePoint -> Int+partUtf8CompleteLen c@(PartialUtf8CodePoint w)+ | partUtf8Len c == 0 = 0+ | 0xf0 <= firstByte = 4+ | 0xe0 <= firstByte = 3+ | 0xc2 <= firstByte = 2+ | otherwise = 0+ where+ firstByte = (w `shiftR` 16) .&. 255++-- | Get the @n@-th byte, assuming it is within bounds: @0 <= n < partUtf8Len c@.+--+-- Unsafe: no bounds checking.+partUtf8UnsafeIndex ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ PartialUtf8CodePoint -> Int -> Word8+partUtf8UnsafeIndex _c@(PartialUtf8CodePoint w) n =+#if defined(ASSERTS)+ assert (0 <= n && n < partUtf8Len _c) $+#endif+ fromIntegral $ w `shiftR` (16 - 8 * n)++-- | Append some bytes.+--+-- Unsafe: no bounds checking.+partUtf8UnsafeAppend ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ PartialUtf8CodePoint -> ByteString -> PartialUtf8CodePoint+partUtf8UnsafeAppend c@(PartialUtf8CodePoint word) bs =+#if defined(ASSERTS)+ assert (lenc + lenbs <= 3) $+#endif+ PartialUtf8CodePoint $+ tryPush 0 $ tryPush 1 $ tryPush 2 $ word + (fromIntegral lenbs `shiftL` 24)+ where+ lenc = partUtf8Len c+ lenbs = B.length bs+ tryPush i w =+ if i < lenbs+ then w + (fromIntegral (B.index bs i) `shiftL` fromIntegral (16 - 8 * (lenc + i)))+ else w++-- | Fold a 'PartialUtf8CodePoint'. This avoids recursion so it can unfold to straightline code.+{-# INLINE partUtf8Foldr #-}+partUtf8Foldr :: (Word8 -> a -> a) -> a -> PartialUtf8CodePoint -> a+partUtf8Foldr f x0 c = case partUtf8Len c of+ 0 -> x0+ 1 -> build 0 x0+ 2 -> build 0 (build 1 x0)+ _ -> build 0 (build 1 (build 2 x0))+ where+ build i x = f (partUtf8UnsafeIndex c i) x++-- | Convert 'PartialUtf8CodePoint' to 'ByteString'.+partUtf8ToByteString :: PartialUtf8CodePoint -> B.ByteString+partUtf8ToByteString c = BI.unsafeCreate (partUtf8Len c) $ \ptr ->+ partUtf8Foldr (\w k i -> pokeElemOff ptr i w >> k (i+1)) (\_ -> pure ()) c 0++-- | Exported for testing.+getCompleteLen :: Utf8State -> Int+getCompleteLen = partUtf8CompleteLen . partialUtf8CodePoint++-- | Exported for testing.+getPartialUtf8 :: Utf8State -> B.ByteString+getPartialUtf8 = partUtf8ToByteString . partialUtf8CodePoint++#ifdef SIMDUTF+foreign import ccall unsafe "_hs_text_is_valid_utf8" c_is_valid_utf8+ :: Ptr Word8 -> CSize -> IO CInt+#endif++-- | Validate a 'ByteString' as UTF-8-encoded text. To be continued using 'validateUtf8More'.+--+-- See also 'validateUtf8More' for details on the result of this function.+--+-- @+-- 'validateUtf8Chunk' = 'validateUtf8More' 'startUtf8State'+-- @+--+-- @since 2.0.2+--+-- === Properties+--+-- Given:+--+-- @+-- 'validateUtf8Chunk' chunk = (n, ms)+-- @+--+-- - The prefix is valid UTF-8. In particular, it should be accepted+-- by this validation:+--+-- @+-- 'validateUtf8Chunk' ('Data.ByteString.take' n chunk) = (n, Just 'startUtf8State')+-- @+validateUtf8Chunk :: ByteString -> (Int, Maybe Utf8State)+validateUtf8Chunk bs = validateUtf8ChunkFrom 0 bs (,)++-- Assume bytes up to offset @ofs@ have been validated already.+--+-- Using CPS lets us inline the continuation and avoid allocating a @Maybe@+-- in the @decode...@ functions.+{-# 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)+ | guessUtf8Boundary > 0 &&+ -- the rest of the bytestring is valid utf-8 up to the boundary+ (+#ifdef SIMDUTF+ withBS (B.drop ofs bs) $ \ fp _ -> unsafeDupablePerformIO $+ unsafeWithForeignPtr fp $ \ptr -> (/= 0) <$>+ c_is_valid_utf8 ptr (fromIntegral guessUtf8Boundary)+#else+ B.isValidUtf8 $ B.take guessUtf8Boundary (B.drop ofs bs)+#endif+ ) = slowValidateUtf8ChunkFrom (ofs + guessUtf8Boundary)+ -- No+ | otherwise = slowValidateUtf8ChunkFrom ofs+ where+ len = B.length bs - ofs+ isBoundary n p = len >= n && p (B.index bs (ofs + len - n))+ guessUtf8Boundary+ | isBoundary 1 (<= 0x80) = len -- last char is ASCII (common short-circuit)+ | isBoundary 1 (0xc2 <=) = len - 1 -- last char starts a two-(or more-)byte code point+ | isBoundary 2 (0xe0 <=) = len - 2 -- pre-last char starts a three-or-four-byte code point+ | isBoundary 3 (0xf0 <=) = len - 3 -- third to last char starts a four-byte code point+ | otherwise = len+#else+ = slowValidateUtf8ChunkFrom ofs+ where+#endif+ -- A pure Haskell implementation of validateUtf8More.+ -- Ideally the primitives 'B.isValidUtf8' or 'c_is_valid_utf8' should give us+ -- indices to let us avoid this function.+ slowValidateUtf8ChunkFrom :: Int -> r+ slowValidateUtf8ChunkFrom ofs1 = slowLoop ofs1 ofs1 utf8AcceptState++ slowLoop !utf8End i s+ | i < B.length bs =+ case updateDecoderState (B.index bs i) s of+ s' | s' == utf8RejectState -> k utf8End Nothing+ | s' == utf8AcceptState -> slowLoop (i + 1) (i + 1) s'+ | otherwise -> slowLoop utf8End (i + 1) s'+ | otherwise = k utf8End (Just (Utf8State s (partUtf8UnsafeAppend partUtf8Empty (B.drop utf8End bs))))++-- | Validate another 'ByteString' chunk in an ongoing stream of UTF-8-encoded text.+--+-- Returns a pair:+--+-- 1. The first component @n@ is the end position, relative to the current+-- chunk, of the longest prefix of the accumulated bytestring which is valid UTF-8.+-- @n@ may be negative: that happens when an incomplete code point started in+-- a previous chunk and is not completed by the current chunk (either+-- that code point is still incomplete, or it is broken by an invalid byte).+--+-- 2. The second component @ms@ indicates the following:+--+-- - if @ms = Nothing@, the remainder of the chunk contains an invalid byte,+-- within four bytes from position @n@;+-- - if @ms = Just s'@, you can carry on validating another chunk+-- by calling 'validateUtf8More' with the new state @s'@.+--+-- @since 2.0.2+--+-- === Properties+--+-- Given:+--+-- @+-- 'validateUtf8More' s chunk = (n, ms)+-- @+--+-- - If the chunk is invalid, it cannot be extended to be valid.+--+-- @+-- ms = Nothing+-- ==> 'validateUtf8More' s (chunk '<>' more) = (n, Nothing)+-- @+--+-- - Validating two chunks sequentially is the same as validating them+-- together at once:+--+-- @+-- ms = Just s'+-- ==> 'validateUtf8More' s (chunk '<>' more) = 'Data.Bifunctor.first' ('Data.ByteString.length' chunk '+') ('validateUtf8More' s' more)+-- @+validateUtf8More :: Utf8State -> ByteString -> (Int, Maybe Utf8State)+validateUtf8More st bs = validateUtf8MoreCont st bs (,)++-- CPS: inlining the continuation lets us make more tail calls and avoid+-- allocating a @Maybe@ in @decodeWith1/2@.+{-# INLINE validateUtf8MoreCont #-}+validateUtf8MoreCont :: Utf8State -> ByteString -> (Int -> Maybe Utf8State -> r) -> r+validateUtf8MoreCont st@(Utf8State s0 part) bs k+ | len > 0 = loop 0 s0+ | otherwise = k (- partUtf8Len part) (Just st)+ where+ len = B.length bs+ -- Complete an incomplete code point (if there is one)+ -- and then jump to validateUtf8ChunkFrom+ loop !i s+ | s == utf8AcceptState = validateUtf8ChunkFrom i bs k+ | i < len =+ case updateDecoderState (B.index bs i) s of+ s' | s' == utf8RejectState -> k (- partUtf8Len part) Nothing+ | otherwise -> loop (i + 1) s'+ | otherwise = k (- partUtf8Len part) (Just (Utf8State s (partUtf8UnsafeAppend part bs)))++-- Eta-expanded to inline partUtf8Foldr+partUtf8ToStrictBuilder :: PartialUtf8CodePoint -> StrictBuilder+partUtf8ToStrictBuilder c =+ partUtf8Foldr ((<>) . SB.unsafeFromWord8) mempty c++utf8StateToStrictBuilder :: Utf8State -> StrictBuilder+utf8StateToStrictBuilder = partUtf8ToStrictBuilder . partialUtf8CodePoint++-- | Decode another chunk in an ongoing UTF-8 stream.+--+-- Returns a triple:+--+-- 1. A 'StrictBuilder' for the decoded chunk of text. You can accumulate+-- chunks with @('<>')@ or output them with 'SB.toText'.+-- 2. The undecoded remainder of the given chunk, for diagnosing errors+-- and resuming (presumably after skipping some bytes).+-- 3. 'Just' the new state, or 'Nothing' if an invalid byte was encountered+-- (it will be within the first 4 bytes of the undecoded remainder).+--+-- @since 2.0.2+--+-- === Properties+--+-- Given:+--+-- @+-- (pre, suf, ms) = 'decodeUtf8More' s chunk+-- @+--+-- 1. If the output @pre@ is nonempty (alternatively, if @length chunk > length suf@)+--+-- @+-- s2b pre \`'Data.ByteString.append'\` suf = p2b s \`'Data.ByteString.append'\` chunk+-- @+--+-- where+--+-- @+-- s2b = 'Data.Text.Encoding.encodeUtf8' . 'Data.Text.Encoding.toText'+-- p2b = 'Data.Text.Internal.Encoding.partUtf8ToByteString'+-- @+--+-- 2. If the output @pre@ is empty (alternatively, if @length chunk = length suf@)+--+-- @suf = chunk@+--+-- 3. Decoding chunks separately is equivalent to decoding their concatenation.+--+-- Given:+--+-- @+-- (pre1, suf1, Just s1) = 'decodeUtf8More' s chunk1+-- (pre2, suf2, ms2) = 'decodeUtf8More' s1 chunk2+-- (pre3, suf3, ms3) = 'decodeUtf8More' s (chunk1 \`B.append\` chunk2)+-- @+--+-- we have:+--+-- @+-- s2b (pre1 '<>' pre2) = s2b pre3+-- ms2 = ms3+-- @+decodeUtf8More :: Utf8State -> ByteString -> (StrictBuilder, ByteString, Maybe Utf8State)+decodeUtf8More s bs =+ validateUtf8MoreCont s bs $ \len ms ->+ let builder | len <= 0 = mempty+ | otherwise = utf8StateToStrictBuilder s+ <> SB.unsafeFromByteString (B.take len bs)+ in (builder, B.drop len bs, ms)++-- | Decode a chunk of UTF-8 text. To be continued with 'decodeUtf8More'.+--+-- See 'decodeUtf8More' for details on the result.+--+-- @since 2.0.2+--+-- === Properties+--+-- @+-- 'decodeUtf8Chunk' = 'decodeUtf8More' 'startUtf8State'+-- @+--+-- Given:+--+-- @+-- 'decodeUtf8Chunk' chunk = (builder, rest, ms)+-- @+--+-- @builder@ is a prefix and @rest@ is a suffix of @chunk@.+--+-- @+-- 'Data.Text.Encoding.encodeUtf8' ('Data.Text.Encoding.strictBuilderToText' builder) '<>' rest = chunk+-- @+decodeUtf8Chunk :: ByteString -> (StrictBuilder, ByteString, Maybe Utf8State)+decodeUtf8Chunk = decodeUtf8More startUtf8State++-- | Call the error handler on each byte of the partial code point stored in+-- 'Utf8State' and append the results.+--+-- Exported for use in lazy 'Data.Text.Lazy.Encoding.decodeUtf8With'.+--+-- @since 2.0.2+{-# INLINE skipIncomplete #-}+skipIncomplete :: OnDecodeError -> String -> Utf8State -> StrictBuilder+skipIncomplete onErr msg s =+ partUtf8Foldr+ ((<>) . handleUtf8Error onErr msg)+ mempty (partialUtf8CodePoint s)++{-# INLINE handleUtf8Error #-}+handleUtf8Error :: OnDecodeError -> String -> Word8 -> StrictBuilder+handleUtf8Error onErr msg w = case onErr msg (Just w) of+ Just c -> SB.fromChar c+ Nothing -> mempty++-- | Helper for 'Data.Text.Encoding.decodeUtf8With'.+--+-- @since 2.0.2++-- This could be shorter by calling 'decodeUtf8With2' directly, but we make the+-- first call validateUtf8Chunk directly to return even faster in successful+-- cases.+decodeUtf8With1 ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ OnDecodeError -> String -> ByteString -> Text+decodeUtf8With1 onErr msg bs = validateUtf8ChunkFrom 0 bs $ \len ms -> case ms of+ Just s+ | len == B.length bs ->+ let !(SBS.SBS arr) = SBS.toShort bs in+ Text (A.ByteArray arr) 0 len+ | otherwise -> SB.toText $+ SB.unsafeFromByteString (B.take len bs) <> skipIncomplete onErr msg s+ Nothing ->+ let (builder, _, s) = decodeUtf8With2 onErr msg startUtf8State (B.drop (len + 1) bs) in+ SB.toText $+ SB.unsafeFromByteString (B.take len bs) <>+ handleUtf8Error onErr msg (B.index bs len) <>+ builder <>+ skipIncomplete onErr msg s++-- | Helper for 'Data.Text.Encoding.decodeUtf8With',+-- 'Data.Text.Encoding.streamDecodeUtf8With', and lazy+-- 'Data.Text.Lazy.Encoding.decodeUtf8With',+-- which use an 'OnDecodeError' to process bad bytes.+--+-- See 'decodeUtf8Chunk' for a more flexible alternative.+--+-- @since 2.0.2+decodeUtf8With2 ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ OnDecodeError -> String -> Utf8State -> ByteString -> (StrictBuilder, ByteString, Utf8State)+decodeUtf8With2 onErr msg s0 bs = loop s0 0 mempty+ where+ loop s i !builder =+ let nonEmptyPrefix len = builder+ <> utf8StateToStrictBuilder s+ <> SB.unsafeFromByteString (B.take len (B.drop i bs))+ in validateUtf8MoreCont s (B.drop i bs) $ \len ms -> case ms of+ Nothing ->+ if len < 0+ then+ -- If the first byte cannot complete the partial code point in s,+ -- retry from startUtf8State.+ let builder' = builder <> skipIncomplete onErr msg s+ -- Note: loop is strict on builder, so if onErr raises an error it will+ -- be forced here, short-circuiting the loop as desired.+ in loop startUtf8State i builder'+ else+ let builder' = nonEmptyPrefix len+ <> handleUtf8Error onErr msg (B.index bs (i + len))+ in loop startUtf8State (i + len + 1) builder'+ Just s' ->+ let builder' = if len <= 0 then builder else nonEmptyPrefix len+ undecoded = if B.length bs >= partUtf8Len (partialUtf8CodePoint s')+ then B.drop (i + len) bs -- Reuse bs if possible+ else partUtf8ToByteString (partialUtf8CodePoint s')+ in (builder', undecoded, s')
src/Data/Text/Internal/Encoding/Fusion.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}+{-# LANGUAGE BangPatterns, CPP, RankNTypes #-} -- | -- Module : Data.Text.Internal.Encoding.Fusion
src/Data/Text/Internal/Encoding/Utf8.hs view
@@ -34,8 +34,11 @@ , validate3 , validate4 -- * Naive decoding- , DecoderResult(..) , DecoderState(..)+ , utf8AcceptState+ , utf8RejectState+ , updateDecoderState+ , DecoderResult(..) , CodePoint(..) , utf8DecodeStart , utf8DecodeContinue@@ -244,7 +247,7 @@ table# = "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\SOH\SOH\SOH\SOH\SOH\SOH\SOH\SOH\SOH\SOH\SOH\SOH\SOH\SOH\SOH\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\a\b\b\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\STX\n\ETX\ETX\ETX\ETX\ETX\ETX\ETX\ETX\ETX\ETX\ETX\ETX\EOT\ETX\ETX\v\ACK\ACK\ACK\ENQ\b\b\b\b\b\b\b\b\b\b\b"# newtype DecoderState = DecoderState Word8- deriving (Eq)+ deriving (Eq, Show) utf8AcceptState :: DecoderState utf8AcceptState = DecoderState 0@@ -260,6 +263,9 @@ table# :: Addr# table# = "\NUL\f\CAN$<`T\f\f\f0H\f\f\f\f\f\f\f\f\f\f\f\f\f\NUL\f\f\f\f\f\NUL\f\NUL\f\f\f\CAN\f\f\f\f\f\CAN\f\CAN\f\f\f\f\f\f\f\f\f\CAN\f\f\f\f\f\CAN\f\f\f\f\f\f\f\CAN\f\f\f\f\f\f\f\f\f$\f$\f\f\f$\f\f\f\f\f$\f$\f\f\f$\f\f\f\f\f\f\f\f\f\f"#++updateDecoderState :: Word8 -> DecoderState -> DecoderState+updateDecoderState b s = updateState (byteToClass b) s newtype CodePoint = CodePoint Int
src/Data/Text/Internal/Fusion/Common.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, MagicHash, Rank2Types, PartialTypeSignatures #-}+{-# LANGUAGE BangPatterns, MagicHash, RankNTypes, PartialTypeSignatures #-} {-# OPTIONS_GHC -Wno-partial-type-signatures #-} -- | -- Module : Data.Text.Internal.Fusion.Common@@ -123,7 +123,7 @@ import Prelude (Bool(..), Char, Eq, (==), Int, Integral, Maybe(..), Ord(..), Ordering(..), String, (.), ($), (+), (-), (*), (++), (&&), fromIntegral, otherwise)-import qualified Data.List as L+import qualified Data.List as L hiding (head, tail) import qualified Prelude as P import Data.Bits (shiftL, shiftR, (.&.)) import Data.Char (isLetter, isSpace)@@ -551,7 +551,8 @@ -- | /O(n)/ Convert a string to title case, using simple case -- conversion. ----- The first letter of the input is converted to title case, as is+-- The first letter (as determined by 'Data.Char.isLetter')+-- of the input is converted to title case, as is -- every subsequent letter that immediately follows a non-letter. -- Every letter that immediately follows another letter is converted -- to lower case.@@ -560,6 +561,14 @@ -- the Latin small ligature fl (U+FB02) is converted to the -- sequence Latin capital letter F (U+0046) followed by Latin small -- letter l (U+006C).+--+-- This function is not idempotent.+-- Consider lower-case letter @ʼn@ (U+0149 LATIN SMALL LETTER N PRECEDED BY APOSTROPHE).+-- Then 'T.toTitle' @"ʼn"@ = @"ʼN"@: the first (and the only) letter of the input+-- is converted to title case, becoming two letters.+-- Now @ʼ@ (U+02BC MODIFIER LETTER APOSTROPHE) is a modifier letter+-- and as such is recognised as a letter by 'Data.Char.isLetter',+-- so 'T.toTitle' @"ʼN"@ = @"'n"@. -- -- /Note/: this function does not take language or culture specific -- rules into account. For instance, in English, different style
src/Data/Text/Internal/Lazy/Encoding/Fusion.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}+{-# LANGUAGE BangPatterns, CPP, RankNTypes #-} -- | -- Module : Data.Text.Lazy.Encoding.Fusion
src/Data/Text/Internal/Lazy/Search.hs view
@@ -32,7 +32,6 @@ import qualified Data.Text as T (concat, isPrefixOf) import Data.Text.Internal.Fusion.Types (PairS(..)) import Data.Text.Internal.Lazy (Text(..), foldrChunks)-import Data.Text.Unsafe (unsafeDupablePerformIO) import Data.Bits ((.|.), (.&.)) import Foreign.C.Types import GHC.Exts (ByteArray#)@@ -66,7 +65,7 @@ c = index xxs (i + nlast) delta | nextInPattern = nlen + 1 | c == z = skip + 1- | l >= i + nlen = case unsafeDupablePerformIO $+ | l >= i + nlen = case memchr xarr# (intToCSize (xoff + i + nlen)) (intToCSize (l - i - nlen)) z of -1 -> max 1 (l - i - nlen) s -> cSsizeToInt s + 1@@ -142,4 +141,4 @@ cSsizeToInt = fromIntegral foreign import ccall unsafe "_hs_text_memchr" memchr- :: ByteArray# -> CSize -> CSize -> Word8 -> IO CSsize+ :: ByteArray# -> CSize -> CSize -> Word8 -> CSsize
src/Data/Text/Internal/Private.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, Rank2Types, UnboxedTuples #-}+{-# LANGUAGE BangPatterns, CPP, RankNTypes, UnboxedTuples #-} -- | -- Module : Data.Text.Internal.Private
src/Data/Text/Internal/Search.hs view
@@ -37,7 +37,6 @@ import Data.Word (Word64, Word8) import Data.Text.Internal (Text(..)) import Data.Bits ((.|.), (.&.), unsafeShiftL)-import Data.Text.Unsafe (unsafeDupablePerformIO) import Foreign.C.Types import GHC.Exts (ByteArray#) import System.Posix.Types (CSsize(..))@@ -88,7 +87,7 @@ | mask .&. swizzle (A.unsafeIndex harr i) == 0 = loop (i + nlen + 1) | otherwise- = case unsafeDupablePerformIO $ memchr harr# (intToCSize i) (intToCSize (hlen + hoff - i)) z of+ = case memchr harr# (intToCSize i) (intToCSize (hlen + hoff - i)) z of -1 -> [] x -> loop (i + cSsizeToInt x + 1) {-# INLINE indices' #-}@@ -112,4 +111,4 @@ cSsizeToInt = fromIntegral foreign import ccall unsafe "_hs_text_memchr" memchr- :: ByteArray# -> CSize -> CSize -> Word8 -> IO CSsize+ :: ByteArray# -> CSize -> CSize -> Word8 -> CSsize
+ src/Data/Text/Internal/StrictBuilder.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module : Data.Text.Internal.Builder+-- License : BSD-style (see LICENSE)+-- Stability : experimental+--+-- /Warning/: this is an internal module, and does not have a stable+-- API or name. Functions in this module may not check or enforce+-- preconditions expected by public modules. Use at your own risk!+--+-- @since 2.0.2++module Data.Text.Internal.StrictBuilder+ ( StrictBuilder(..)+ , toText+ , fromChar+ , fromText++ -- * Unsafe+ -- $unsafe+ , unsafeFromByteString+ , unsafeFromWord8+ ) where++import Control.Monad.ST (ST, runST)+import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)+import Data.Functor (void)+import Data.Word (Word8)+import Data.ByteString (ByteString)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup(..))+#endif+import Data.Text.Internal (Text(..), empty, safe)+import Data.Text.Internal.ByteStringCompat (withBS)+import Data.Text.Internal.Encoding.Utf8 (utf8Length)+import Data.Text.Internal.Unsafe (unsafeWithForeignPtr)+import qualified Data.ByteString as B+import qualified Data.Text.Array as A+import qualified Data.Text.Internal.Unsafe.Char as Char++-- | A delayed representation of strict 'Text'.+--+-- @since 2.0.2+data StrictBuilder = StrictBuilder+ { sbLength :: {-# UNPACK #-} !Int+ , sbWrite :: forall s. A.MArray s -> Int -> ST s ()+ }++-- | Use 'StrictBuilder' to build 'Text'.+--+-- @since 2.0.2+toText :: StrictBuilder -> Text+toText (StrictBuilder 0 _) = empty+toText (StrictBuilder n write) = runST (do+ dst <- A.new n+ write dst 0+ arr <- A.unsafeFreeze dst+ pure (Text arr 0 n))++-- | Concatenation of 'StrictBuilder' is right-biased:+-- the right builder will be run first. This allows a builder to+-- run tail-recursively when it was accumulated left-to-right.+instance Semigroup StrictBuilder where+ (<>) = appendRStrictBuilder++instance Monoid StrictBuilder where+ mempty = emptyStrictBuilder+ mappend = (<>)++emptyStrictBuilder :: StrictBuilder+emptyStrictBuilder = StrictBuilder 0 (\_ _ -> pure ())++appendRStrictBuilder :: StrictBuilder -> StrictBuilder -> StrictBuilder+appendRStrictBuilder (StrictBuilder 0 _) b2 = b2+appendRStrictBuilder b1 (StrictBuilder 0 _) = b1+appendRStrictBuilder (StrictBuilder n1 write1) (StrictBuilder n2 write2) =+ StrictBuilder (n1 + n2) (\dst ofs -> do+ write2 dst (ofs + n1)+ write1 dst ofs)++copyFromByteString :: A.MArray s -> Int -> ByteString -> ST s ()+copyFromByteString dst ofs src = withBS src $ \ srcFPtr len ->+ unsafeIOToST $ unsafeWithForeignPtr srcFPtr $ \ srcPtr -> do+ unsafeSTToIO $ A.copyFromPointer dst ofs srcPtr len++-- | Copy a 'ByteString'.+--+-- Unsafe: This may not be valid UTF-8 text.+--+-- @since 2.0.2+unsafeFromByteString :: ByteString -> StrictBuilder+unsafeFromByteString bs =+ StrictBuilder (B.length bs) (\dst ofs -> copyFromByteString dst ofs bs)++-- |+-- @since 2.0.2+{-# INLINE fromChar #-}+fromChar :: Char -> StrictBuilder+fromChar c =+ StrictBuilder (utf8Length c) (\dst ofs -> void (Char.unsafeWrite dst ofs (safe c)))++-- $unsafe+-- For internal purposes, we abuse 'StrictBuilder' as a delayed 'Array' rather+-- than 'Text': it may not actually be valid 'Text'.++-- | Unsafe: This may not be valid UTF-8 text.+--+-- @since 2.0.2+unsafeFromWord8 :: Word8 -> StrictBuilder+unsafeFromWord8 !w =+ StrictBuilder 1 (\dst ofs -> A.unsafeWrite dst ofs w)++-- | Copy 'Text' in a 'StrictBuilder'+--+-- @since 2.0.2+fromText :: Text -> StrictBuilder+fromText (Text src srcOfs n) = StrictBuilder n (\dst dstOfs ->+ A.copyI n dst dstOfs src srcOfs)
src/Data/Text/Lazy.hs view
@@ -108,6 +108,7 @@ , all , maximum , minimum+ , isAscii -- * Construction @@ -210,7 +211,7 @@ import Control.DeepSeq (NFData(..)) import Data.Bits (finiteBitSize) import Data.Int (Int64)-import qualified Data.List as L+import qualified Data.List as L hiding (head, tail) import Data.Char (isSpace) import Data.Data (Data(gfoldl, toConstr, gunfold, dataTypeOf), constrIndex, Constr, mkConstr, DataType, mkDataType, Fixity(Prefix))@@ -727,7 +728,7 @@ -- case folded to the Greek small letter letter mu (U+03BC) instead of -- itself. toCaseFold :: Text -> Text-toCaseFold t = unstream (S.toCaseFold (stream t))+toCaseFold = foldrChunks (\chnk acc -> Chunk (T.toCaseFold chnk) acc) Empty {-# INLINE toCaseFold #-} -- | /O(n)/ Convert a string to lower case, using simple case@@ -738,7 +739,7 @@ -- to the sequence Latin small letter i (U+0069) followed by combining -- dot above (U+0307). toLower :: Text -> Text-toLower t = unstream (S.toLower (stream t))+toLower = foldrChunks (\chnk acc -> Chunk (T.toLower chnk) acc) Empty {-# INLINE toLower #-} -- | /O(n)/ Convert a string to upper case, using simple case@@ -748,14 +749,15 @@ -- instance, the German eszett (U+00DF) maps to the two-letter -- sequence SS. toUpper :: Text -> Text-toUpper t = unstream (S.toUpper (stream t))+toUpper = foldrChunks (\chnk acc -> Chunk (T.toUpper chnk) acc) Empty {-# INLINE toUpper #-} -- | /O(n)/ Convert a string to title case, using simple case -- conversion. ----- The first letter of the input is converted to title case, as is+-- The first letter (as determined by 'Data.Char.isLetter')+-- of the input is converted to title case, as is -- every subsequent letter that immediately follows a non-letter. -- Every letter that immediately follows another letter is converted -- to lower case.@@ -765,6 +767,14 @@ -- sequence Latin capital letter F (U+0046) followed by Latin small -- letter l (U+006C). --+-- This function is not idempotent.+-- Consider lower-case letter @ʼn@ (U+0149 LATIN SMALL LETTER N PRECEDED BY APOSTROPHE).+-- Then 'T.toTitle' @"ʼn"@ = @"ʼN"@: the first (and the only) letter of the input+-- is converted to title case, becoming two letters.+-- Now @ʼ@ (U+02BC MODIFIER LETTER APOSTROPHE) is a modifier letter+-- and as such is recognised as a letter by 'Data.Char.isLetter',+-- so 'T.toTitle' @"ʼN"@ = @"'n"@.+-- -- /Note/: this function does not take language or culture specific -- rules into account. For instance, in English, different style -- guides disagree on whether the book name \"The Hill of the Red@@ -773,7 +783,7 @@ -- -- @since 1.0.0.0 toTitle :: Text -> Text-toTitle t = unstream (S.toTitle (stream t))+toTitle = foldrChunks (\chnk acc -> Chunk (T.toTitle chnk) acc) Empty {-# INLINE toTitle #-} -- | /O(n)/ 'foldl', applied to a binary operator, a starting value@@ -861,6 +871,26 @@ minimum t = S.minimum (stream t) {-# INLINE minimum #-} +-- | \O(n)\ Test whether 'Text' contains only ASCII code-points (i.e. only+-- U+0000 through U+007F).+--+-- This is a more efficient version of @'all' 'Data.Char.isAscii'@.+--+-- >>> isAscii ""+-- True+--+-- >>> isAscii "abc\NUL"+-- True+--+-- >>> isAscii "abcd€"+-- False+--+-- prop> isAscii t == all (< '\x80') t+--+-- @since 2.0.2+isAscii :: Text -> Bool+isAscii = foldrChunks (\chnk acc -> T.isAscii chnk && acc) True+ -- | /O(n)/ 'scanl' is similar to 'foldl', but returns a list of -- successive reduced values from the left. -- Performs replacement on invalid scalar values.@@ -1396,7 +1426,7 @@ inits :: Text -> [Text] inits = (Empty :) . inits' where inits' Empty = []- inits' (Chunk t ts) = L.map (\t' -> Chunk t' Empty) (L.tail (T.inits t))+ inits' (Chunk t ts) = L.map (\t' -> Chunk t' Empty) (L.drop 1 (T.inits t)) ++ L.map (Chunk t) (inits' ts) -- | /O(n)/ Return all final segments of the given 'Text', longest
src/Data/Text/Lazy/Builder.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}+{-# LANGUAGE BangPatterns, CPP, RankNTypes #-} {-# LANGUAGE Trustworthy #-} -----------------------------------------------------------------------------
src/Data/Text/Lazy/Encoding.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns,CPP #-} {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Text.Lazy.Encoding@@ -60,15 +61,15 @@ import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode) import Data.Text.Internal.Lazy (Text(..), chunk, empty, foldrChunks) import Data.Word (Word8)-import qualified Data.ByteString as S import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Builder.Prim as BP import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Internal as B-import qualified Data.Text as T import qualified Data.Text.Encoding as TE+import qualified Data.Text.Internal.Encoding as TE import qualified Data.Text.Internal.Lazy.Encoding.Fusion as E import qualified Data.Text.Internal.Lazy.Fusion as F+import qualified Data.Text.Internal.StrictBuilder as SB import Data.Text.Unsafe (unsafeDupablePerformIO) -- $strict@@ -106,24 +107,14 @@ -- | Decode a 'ByteString' containing UTF-8 encoded text. decodeUtf8With :: OnDecodeError -> B.ByteString -> Text-decodeUtf8With onErr (B.Chunk b0 bs0) =- case TE.streamDecodeUtf8With onErr b0 of- TE.Some t l f -> chunk t (go f l bs0)+decodeUtf8With onErr = loop TE.startUtf8State where- go f0 _ (B.Chunk b bs) =- case f0 b of- TE.Some t l f -> chunk t (go f l bs)- go _ l _- | S.null l = empty- | otherwise =- let !t = T.pack (skipBytes l)- skipBytes = S.foldr (\x s' ->- case onErr desc (Just x) of- Just c -> c : s'- Nothing -> s') [] in- Chunk t Empty- desc = "Data.Text.Lazy.Encoding.decodeUtf8With: Invalid UTF-8 stream"-decodeUtf8With _ _ = empty+ chunkb builder t | SB.sbLength builder == 0 = t+ | otherwise = Chunk (TE.strictBuilderToText builder) t+ loop s (B.Chunk b bs) = case TE.decodeUtf8With2 onErr msg s b of+ (builder, _, s') -> chunkb builder (loop s' bs)+ loop s B.Empty = chunkb (TE.skipIncomplete onErr msg s) Empty+ msg = "Data.Text.Internal.Encoding: Invalid UTF-8 stream" -- | Decode a 'ByteString' containing UTF-8 encoded text that is known -- to be valid.
src/Data/Text/Show.hs view
@@ -24,16 +24,15 @@ ) where import Control.Monad.ST (ST, runST)-import Data.Text.Internal (Text(..), empty_, safe)+import Data.Text.Internal (Text(..), empty_, safe, pack) import Data.Text.Internal.Encoding.Utf8 (utf8Length)-import Data.Text.Internal.Fusion (stream, unstream)+import Data.Text.Internal.Fusion (stream) import Data.Text.Internal.Unsafe.Char (unsafeWrite) import GHC.Exts (Ptr(..), Int(..), Addr#, indexWord8OffAddr#) import GHC.Word (Word8(..)) import qualified Data.Text.Array as A import qualified Data.Text.Internal.Fusion.Common as S #if !MIN_VERSION_ghc_prim(0,7,0)-import Data.Text.Internal.Unsafe (inlinePerformIO) import Foreign.C.String (CString) import Foreign.C.Types (CSize(..)) #endif@@ -87,8 +86,12 @@ A.shrinkM marr actualLen arr <- A.unsafeFreeze marr return $ Text arr 0 actualLen-{-# INLINE unpackCString# #-} +-- When a module contains many literal strings, 'unpackCString#' can easily+-- bloat generated code to insane size. There is also very little to gain+-- from inlining. Thus explicit NOINLINE is desired.+{-# NOINLINE unpackCString# #-}+ -- | /O(n)/ Convert a null-terminated ASCII string to a 'Text'. -- Counterpart to 'GHC.unpackCString#'. -- No validation is performed, malformed input can lead to memory access violation.@@ -102,32 +105,28 @@ marr <- A.new l A.copyFromPointer marr 0 (Ptr addr#) l A.unsafeFreeze marr-{-# INLINE unpackCStringAscii# #-}+{-# NOINLINE unpackCStringAscii# #-} addrLen :: Addr# -> Int #if MIN_VERSION_ghc_prim(0,7,0) addrLen addr# = I# (GHC.cstringLength# addr#) #else-addrLen addr# = fromIntegral (inlinePerformIO (c_strlen (Ptr addr#)))+addrLen addr# = fromIntegral (c_strlen (Ptr addr#)) -foreign import capi unsafe "string.h strlen" c_strlen :: CString -> IO CSize+foreign import capi unsafe "string.h strlen" c_strlen :: CString -> CSize #endif -{-# RULES "TEXT literal" [1] forall a.- unstream (S.map safe (S.streamList (GHC.unpackCString# a)))- = unpackCStringAscii# a #-}+{-# RULES "TEXT literal" forall a.+ pack (GHC.unpackCString# a) = unpackCStringAscii# a #-} -{-# RULES "TEXT literal UTF8" [1] forall a.- unstream (S.map safe (S.streamList (GHC.unpackCStringUtf8# a)))- = unpackCString# a #-}+{-# RULES "TEXT literal UTF8" forall a.+ pack (GHC.unpackCStringUtf8# a) = unpackCString# a #-} -{-# RULES "TEXT empty literal" [1]- unstream (S.map safe (S.streamList []))- = empty_ #-}+{-# RULES "TEXT empty literal"+ pack [] = empty_ #-} -{-# RULES "TEXT singleton literal" [1] forall a.- unstream (S.map safe (S.streamList [a]))- = singleton_ a #-}+{-# RULES "TEXT singleton literal" forall a.+ pack [a] = singleton a #-} -- | /O(1)/ Convert a character into a Text. -- Performs replacement on invalid scalar values.@@ -136,24 +135,11 @@ HasCallStack => #endif Char -> Text-singleton = unstream . S.singleton . safe-{-# INLINE [1] singleton #-}--{-# RULES "TEXT singleton" forall a.- unstream (S.singleton (safe a))- = singleton_ a #-}---- This is intended to reduce inlining bloat.-singleton_ ::-#if defined(ASSERTS)- HasCallStack =>-#endif- Char -> Text-singleton_ c = Text (A.run x) 0 len+singleton c = Text (A.run x) 0 len where x :: ST s (A.MArray s) x = do arr <- A.new len _ <- unsafeWrite arr 0 d return arr len = utf8Length d d = safe c-{-# NOINLINE singleton_ #-}+{-# NOINLINE singleton #-}
tests/Tests/Properties/Basics.hs view
@@ -2,7 +2,9 @@ {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_GHC -Wno-warnings-deprecations #-}+ module Tests.Properties.Basics ( testBasics ) where
tests/Tests/Properties/Folds.hs view
@@ -11,7 +11,7 @@ import Control.Exception (ErrorCall, evaluate, try) import Data.Word (Word8, Word16) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (testCase, assertFailure)+import Test.Tasty.HUnit (testCase, assertFailure, assertBool) import Test.Tasty.QuickCheck (testProperty, Small(..), (===), applyFun, applyFun2) import Tests.QuickCheckUtils import qualified Data.List as L@@ -19,6 +19,7 @@ import qualified Data.Text.Internal.Fusion as S import qualified Data.Text.Internal.Fusion.Common as S import qualified Data.Text.Lazy as TL+import qualified Data.Char as Char -- Folds @@ -109,6 +110,8 @@ = (L.minimum . L.filter p) `eqP` (S.minimum . S.filter p) t_minimum = L.minimum `eqP` T.minimum tl_minimum = L.minimum `eqP` TL.minimum+t_isAscii = L.all Char.isAscii `eqP` T.isAscii+tl_isAscii = L.all Char.isAscii `eqP` TL.isAscii -- Scans @@ -190,6 +193,11 @@ where i = fromIntegral (n :: Word16) j = fromIntegral (m :: Word16) +isAscii_border :: IO ()+isAscii_border = do+ let text = T.drop 2 $ T.pack "XX1234五"+ assertBool "UTF-8 string with ASCII prefix ending at last position incorrectly detected as ASCII" $ not $ T.isAscii text+ testFolds :: TestTree testFolds = testGroup "folds-unfolds" [@@ -234,7 +242,10 @@ testProperty "tl_maximum" tl_maximum, testProperty "sf_minimum" sf_minimum, testProperty "t_minimum" t_minimum,- testProperty "tl_minimum" tl_minimum+ testProperty "tl_minimum" tl_minimum,+ testProperty "t_isAscii " t_isAscii,+ testProperty "tl_isAscii " tl_isAscii,+ testCase "isAscii_border" isAscii_border ] ],
tests/Tests/Properties/LowLevel.hs view
@@ -13,6 +13,7 @@ module Tests.Properties.LowLevel (testLowLevel) where +import Prelude hiding (head, tail) import Control.Applicative ((<$>), pure) import Control.Exception as E (SomeException, catch, evaluate) import Data.Int (Int32, Int64)@@ -101,9 +102,9 @@ t_write_read = write_read T.unlines T.filter T.hPutStr T.hGetContents tl_write_read = write_read TL.unlines TL.filter TL.hPutStr TL.hGetContents -t_write_read_line m b t = write_read head T.filter T.hPutStrLn+t_write_read_line m b t = write_read (T.concat . take 1) T.filter T.hPutStrLn T.hGetLine m b [t]-tl_write_read_line m b t = write_read head TL.filter TL.hPutStrLn+tl_write_read_line m b t = write_read (TL.concat . take 1) TL.filter TL.hPutStrLn TL.hGetLine m b [t]
tests/Tests/Properties/Substrings.hs view
@@ -7,6 +7,7 @@ ( testSubstrings ) where +import Prelude hiding (head, tail) import Control.Monad.Trans.State (State, state, runState) import Data.Char (isSpace) import Test.QuickCheck@@ -218,9 +219,10 @@ split :: (a -> Bool) -> [a] -> [[a]] split _ [] = [[]] split p xs = loop xs- where loop s | null s' = [l]- | otherwise = l : loop (tail s')- where (l, s') = break p s+ where+ loop s = case break p s of+ (l, []) -> [l]+ (l, _ : s') -> l : loop s' t_chunksOf_same_lengths k = conjoin . map ((===k) . T.length) . ini . T.chunksOf k where ini [] = []@@ -237,7 +239,9 @@ t_lines_spacy = (L.lines `eqP` (map unpackS . T.lines)) . getSpacyString tl_lines_spacy = (L.lines `eqP` (map unpackS . TL.lines)) . getSpacyString -tl_lines_laziness = TL.head (head (TL.lines (TL.replicate 1000000000000000 (TL.singleton 'a')))) === 'a'+tl_lines_laziness = case TL.lines (TL.replicate 1000000000000000 (TL.singleton 'a')) of+ [] -> property False+ hd : _ -> TL.head hd === 'a' tl_lines_specialCase = TL.lines (TL.Chunk (T.pack "foo") $ TL.Chunk (T.pack "bar\nbaz\n") $ TL.Empty) === [TL.pack "foobar", TL.pack "baz"]
tests/Tests/Properties/Text.hs view
@@ -1,8 +1,11 @@ -- | Tests for operations that don't fit in the other @Test.Properties.*@ modules. {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-}+ {-# OPTIONS_GHC -fno-warn-missing-signatures #-}+ module Tests.Properties.Text ( testText ) where@@ -100,17 +103,56 @@ (S.length . S.toCaseFold . S.filter p $ s) >= (length . L.filter p $ xs) where s = S.streamList xs t_toCaseFold_length t = T.length (T.toCaseFold t) >= T.length t+ tl_toCaseFold_length t = TL.length (TL.toCaseFold t) >= TL.length t+#if MIN_VERSION_base(4,16,0)+t_toCaseFold_char c = c `notElem` (toCaseFoldExceptions ++ cherokeeLower ++ cherokeeUpper) ==>+ T.toCaseFold (T.singleton c) === T.singleton (C.toLower c)+#endif++-- | Baseline generated with GHC 9.2 + text-1.2.5.0,+t_toCaseFold_exceptions = T.unpack (T.toCaseFold (T.pack toCaseFoldExceptions)) === "\956ssi\775\700nsj\780\953\953\776\769\965\776\769\963\946\952\966\960\954\961\949\1381\1410\5104\5105\5106\5107\5108\5109\1074\1076\1086\1089\1090\1090\1098\1123\42571h\817t\776w\778y\778a\702\7777ss\965\787\965\787\768\965\787\769\965\787\834\7936\953\7937\953\7938\953\7939\953\7940\953\7941\953\7942\953\7943\953\7936\953\7937\953\7938\953\7939\953\7940\953\7941\953\7942\953\7943\953\7968\953\7969\953\7970\953\7971\953\7972\953\7973\953\7974\953\7975\953\7968\953\7969\953\7970\953\7971\953\7972\953\7973\953\7974\953\7975\953\8032\953\8033\953\8034\953\8035\953\8036\953\8037\953\8038\953\8039\953\8032\953\8033\953\8034\953\8035\953\8036\953\8037\953\8038\953\8039\953\8048\953\945\953\940\953\945\834\945\834\953\945\953\953\8052\953\951\953\942\953\951\834\951\834\953\951\953\953\776\768\953\776\769\953\834\953\776\834\965\776\768\965\776\769\961\787\965\834\965\776\834\8060\953\969\953\974\953\969\834\969\834\953\969\953fffiflffifflstst\1396\1398\1396\1381\1396\1387\1406\1398\1396\1389"+t_toCaseFold_cherokeeLower = T.all (`elem` cherokeeUpper) (T.toCaseFold (T.pack cherokeeLower))+t_toCaseFold_cherokeeUpper = conjoin $+ map (\c -> T.toCaseFold (T.singleton c) === T.singleton c) cherokeeUpper++-- | Generated with GHC 9.2 + text-1.2.5.0,+-- filter (\c -> c `notElem` (cherokeeUpper ++ cherokeeLower)) $+-- filter (\c -> T.toCaseFold (T.singleton c) /= T.singleton (Data.Char.toLower c))+-- [minBound .. maxBound]+toCaseFoldExceptions = "\181\223\304\329\383\496\837\912\944\962\976\977\981\982\1008\1009\1013\1415\5112\5113\5114\5115\5116\5117\7296\7297\7298\7299\7300\7301\7302\7303\7304\7830\7831\7832\7833\7834\7835\7838\8016\8018\8020\8022\8064\8065\8066\8067\8068\8069\8070\8071\8072\8073\8074\8075\8076\8077\8078\8079\8080\8081\8082\8083\8084\8085\8086\8087\8088\8089\8090\8091\8092\8093\8094\8095\8096\8097\8098\8099\8100\8101\8102\8103\8104\8105\8106\8107\8108\8109\8110\8111\8114\8115\8116\8118\8119\8124\8126\8130\8131\8132\8134\8135\8140\8146\8147\8150\8151\8162\8163\8164\8166\8167\8178\8179\8180\8182\8183\8188\64256\64257\64258\64259\64260\64261\64262\64275\64276\64277\64278\64279"+cherokeeUpper = ['\x13A0'..'\x13F7'] -- x13F8..13FF are lowercase+cherokeeLower = ['\xAB70'..'\xABBF']+ t_toLower_length t = T.length (T.toLower t) >= T.length t t_toLower_lower t = p (T.toLower t) >= p t where p = T.length . T.filter isLower tl_toLower_lower t = p (TL.toLower t) >= p t where p = TL.length . TL.filter isLower+#if MIN_VERSION_base(4,13,0)+t_toLower_char c = c /= '\304' ==>+ T.toLower (T.singleton c) === T.singleton (C.toLower c)+#endif+t_toLower_dotted_i = T.unpack (T.toLower (T.singleton '\304')) === "i\775"+ t_toUpper_length t = T.length (T.toUpper t) >= T.length t t_toUpper_upper t = p (T.toUpper t) >= p t where p = T.length . T.filter isUpper tl_toUpper_upper t = p (TL.toUpper t) >= p t where p = TL.length . TL.filter isUpper+#if MIN_VERSION_base(4,13,0)+t_toUpper_char c = c `notElem` toUpperExceptions ==>+ T.toUpper (T.singleton c) === T.singleton (C.toUpper c)+#endif++-- | Baseline generated with GHC 9.2 + text-1.2.5.0,+t_toUpper_exceptions = T.unpack (T.toUpper (T.pack toUpperExceptions)) === "SS\700NJ\780\921\776\769\933\776\769\1333\1362H\817T\776W\778Y\778A\702\933\787\933\787\768\933\787\769\933\787\834\7944\921\7945\921\7946\921\7947\921\7948\921\7949\921\7950\921\7951\921\7944\921\7945\921\7946\921\7947\921\7948\921\7949\921\7950\921\7951\921\7976\921\7977\921\7978\921\7979\921\7980\921\7981\921\7982\921\7983\921\7976\921\7977\921\7978\921\7979\921\7980\921\7981\921\7982\921\7983\921\8040\921\8041\921\8042\921\8043\921\8044\921\8045\921\8046\921\8047\921\8040\921\8041\921\8042\921\8043\921\8044\921\8045\921\8046\921\8047\921\8122\921\913\921\902\921\913\834\913\834\921\913\921\8138\921\919\921\905\921\919\834\919\834\921\919\921\921\776\768\921\776\769\921\834\921\776\834\933\776\768\933\776\769\929\787\933\834\933\776\834\8186\921\937\921\911\921\937\834\937\834\921\937\921FFFIFLFFIFFLSTST\1348\1350\1348\1333\1348\1339\1358\1350\1348\1341"++-- | Generated with GHC 9.2 + text-1.2.5.0,+-- filter (\c -> T.toUpper (T.singleton c) /= T.singleton (Data.Char.toUpper c))+-- [minBound .. maxBound]+toUpperExceptions = "\223\329\496\912\944\1415\7830\7831\7832\7833\7834\8016\8018\8020\8022\8064\8065\8066\8067\8068\8069\8070\8071\8072\8073\8074\8075\8076\8077\8078\8079\8080\8081\8082\8083\8084\8085\8086\8087\8088\8089\8090\8091\8092\8093\8094\8095\8096\8097\8098\8099\8100\8101\8102\8103\8104\8105\8106\8107\8108\8109\8110\8111\8114\8115\8116\8118\8119\8124\8130\8131\8132\8134\8135\8140\8146\8147\8150\8151\8162\8163\8164\8166\8167\8178\8179\8180\8182\8183\8188\64256\64257\64258\64259\64260\64261\64262\64275\64276\64277\64278\64279"+ t_toTitle_title t = all (<= 1) (caps w) where caps = fmap (T.length . T.filter isUpper) . T.words . T.toTitle -- TIL: there exist uppercase-only letters@@ -127,10 +169,21 @@ -- Georgian text does not have a concept of title case -- https://en.wikipedia.org/wiki/Georgian_Extended isGeorgian c = c >= '\4256' && c < '\4352'+#if MIN_VERSION_base(4,13,0)+t_toTitle_char c = c `notElem` toTitleExceptions ==>+ T.toTitle (T.singleton c) === T.singleton (C.toUpper c)+#endif +-- | Baseline generated with GHC 9.2 + text-1.2.5.0,+t_toTitle_exceptions = T.unpack (T.concatMap (T.toTitle . T.singleton) (T.pack toTitleExceptions)) === "Ss\700N\453\453\453\456\456\456\459\459\459J\780\498\498\498\921\776\769\933\776\769\1333\1410\4304\4305\4306\4307\4308\4309\4310\4311\4312\4313\4314\4315\4316\4317\4318\4319\4320\4321\4322\4323\4324\4325\4326\4327\4328\4329\4330\4331\4332\4333\4334\4335\4336\4337\4338\4339\4340\4341\4342\4343\4344\4345\4346\4349\4350\4351H\817T\776W\778Y\778A\702\933\787\933\787\768\933\787\769\933\787\834\8122\837\902\837\913\834\913\834\837\8138\837\905\837\919\834\919\834\837\921\776\768\921\776\769\921\834\921\776\834\933\776\768\933\776\769\929\787\933\834\933\776\834\8186\837\911\837\937\834\937\834\837FfFiFlFfiFflStSt\1348\1398\1348\1381\1348\1387\1358\1398\1348\1389"++-- | Generated with GHC 9.2 + text-1.2.5.0,+-- filter (\c -> T.toTitle (T.singleton c) /= T.singleton (Data.Char.toUpper c))+-- [minBound .. maxBound]+toTitleExceptions = "\223\329\452\453\454\455\456\457\458\459\460\496\497\498\499\912\944\1415\4304\4305\4306\4307\4308\4309\4310\4311\4312\4313\4314\4315\4316\4317\4318\4319\4320\4321\4322\4323\4324\4325\4326\4327\4328\4329\4330\4331\4332\4333\4334\4335\4336\4337\4338\4339\4340\4341\4342\4343\4344\4345\4346\4349\4350\4351\7830\7831\7832\7833\7834\8016\8018\8020\8022\8114\8116\8118\8119\8130\8132\8134\8135\8146\8147\8150\8151\8162\8163\8164\8166\8167\8178\8180\8182\8183\64256\64257\64258\64259\64260\64261\64262\64275\64276\64277\64278\64279"+ t_toUpper_idempotent t = T.toUpper (T.toUpper t) === T.toUpper t t_toLower_idempotent t = T.toLower (T.toLower t) === T.toLower t-t_toTitle_idempotent t = T.toTitle (T.toTitle t) === T.toTitle t t_toCaseFold_idempotent t = T.toCaseFold (T.toCaseFold t) === T.toCaseFold t ascii_toLower (ASCIIString xs) = map C.toLower xs === T.unpack (T.toLower (T.pack xs))@@ -328,18 +381,38 @@ testProperty "sf_toCaseFold_length" sf_toCaseFold_length, testProperty "t_toCaseFold_length" t_toCaseFold_length, testProperty "tl_toCaseFold_length" tl_toCaseFold_length,+#if MIN_VERSION_base(4,16,0)+ testProperty "t_toCaseFold_char" t_toCaseFold_char,+#endif+ testProperty "t_toCaseFold_exceptions" t_toCaseFold_exceptions,+ testProperty "t_toCaseFold_cherokeeLower" t_toCaseFold_cherokeeLower,+ testProperty "t_toCaseFold_cherokeeUpper" t_toCaseFold_cherokeeUpper,+ testProperty "t_toLower_length" t_toLower_length, testProperty "t_toLower_lower" t_toLower_lower, testProperty "tl_toLower_lower" tl_toLower_lower,+ testProperty "t_toLower_dotted_i" t_toLower_dotted_i,+ testProperty "t_toUpper_length" t_toUpper_length, testProperty "t_toUpper_upper" t_toUpper_upper, testProperty "tl_toUpper_upper" tl_toUpper_upper,+ testProperty "t_toUpper_exceptions" t_toUpper_exceptions,+ testProperty "t_toTitle_title" t_toTitle_title, testProperty "t_toTitle_1stNotLower" t_toTitle_1stNotLower,+ testProperty "t_toTitle_exceptions" t_toTitle_exceptions,++#if MIN_VERSION_base(4,13,0)+ -- Requires base compliant with Unicode 12.0+ testProperty "t_toLower_char" t_toLower_char,+ testProperty "t_toUpper_char" t_toUpper_char,+ testProperty "t_toTitle_char" t_toTitle_char,+#endif+ testProperty "t_toUpper_idempotent" t_toUpper_idempotent, testProperty "t_toLower_idempotent" t_toLower_idempotent,- testProperty "t_toTitle_idempotent" t_toTitle_idempotent, testProperty "t_toCaseFold_idempotent" t_toCaseFold_idempotent,+ testProperty "ascii_toLower" ascii_toLower, testProperty "ascii_toUpper" ascii_toUpper, testProperty "ascii_toTitle" ascii_toTitle,
tests/Tests/Properties/Transcoding.hs view
@@ -1,16 +1,24 @@ -- | Tests for encoding and decoding -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Tests.Properties.Transcoding ( testTranscoding ) where +import Prelude hiding (head, tail) import Data.Bits ((.&.), shiftR) import Data.Char (chr, ord)+import Data.Functor (void)+import Data.Maybe (isNothing)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup ((<>))+#endif+import Data.Word (Word8) import Test.QuickCheck hiding ((.&.)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty)+import Test.Tasty.HUnit ((@?=), assertBool, assertFailure, testCase) import Tests.QuickCheckUtils import qualified Control.Exception as Exception import qualified Data.Bits as Bits (shiftL, shiftR)@@ -24,6 +32,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding.Error as E+import qualified Data.Text.Internal.Encoding as E import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as EL @@ -35,6 +44,167 @@ t_latin1 = E.decodeLatin1 `eq` (T.pack . BC.unpack) tl_latin1 = EL.decodeLatin1 `eq` (TL.pack . BLC.unpack) +t_p_utf8_1 = testValidateUtf8_ [0x63] 1+t_p_utf8_2 = testValidateUtf8_ [0x63, 0x63, 0x63] 3+t_p_utf8_3 = testValidateUtf8_ [0x63, 0x63, 0xc2, 0x80, 0x63] 5+t_p_utf8_4 = testValidateUtf8_ [0x63, 0xe1, 0x80, 0x80, 0x63] 5+t_p_utf8_5 = testValidateUtf8_ [0xF0, 0x90, 0x80, 0x80, 0x63] 5+t_p_utf8_6 = testValidateUtf8_ [0x63, 0x63, 0xF0, 0x90, 0x80] 2+t_p_utf8_7 = testValidateUtf8_ [0x63, 0x63, 0x63, 0xF0, 0x90] 3+t_p_utf8_8 = testValidateUtf8Fail [0xF0, 0x90, 0x80, 0x63, 0x63] 0+t_p_utf8_9 = testValidateUtf8Fail [0x63, 0x63, 0x80, 0x63, 0x63] 2+t_p_utf8_0 = testValidateUtf8Fail [0x63, 0x63, 0xe1, 0x63, 0x63] 2++testValidateUtf8With ::+ (B.ByteString -> (Int, Maybe E.Utf8State)) ->+ (Maybe E.Utf8State -> IO r) ->+ [Word8] -> Int -> IO r+testValidateUtf8With validate k xs expectedLen = case validate (B.pack xs) of+ (len, s) -> do+ len @?= expectedLen+ k s++expectJust :: Maybe a -> IO a+expectJust Nothing = assertFailure "Unexpected Nothing"+expectJust (Just s) = pure s++expectNothing :: Maybe a -> IO ()+expectNothing Nothing = pure ()+expectNothing (Just _) = assertFailure "Unexpected Just"++testValidateUtf8 :: [Word8] -> Int -> IO E.Utf8State+testValidateUtf8 = testValidateUtf8With E.validateUtf8Chunk expectJust++testValidateUtf8_ :: [Word8] -> Int -> IO ()+testValidateUtf8_ = testValidateUtf8With E.validateUtf8Chunk (void . expectJust)++testValidateUtf8Fail :: [Word8] -> Int -> IO ()+testValidateUtf8Fail = testValidateUtf8With E.validateUtf8Chunk expectNothing++testValidateUtf8More :: E.Utf8State -> [Word8] -> Int -> IO E.Utf8State+testValidateUtf8More s = testValidateUtf8With (E.validateUtf8More s) expectJust++testValidateUtf8MoreFail :: E.Utf8State -> [Word8] -> Int -> IO ()+testValidateUtf8MoreFail s = testValidateUtf8With (E.validateUtf8More s) expectNothing++t_pn_utf8_1 = do+ s <- testValidateUtf8 [0xF0, 0x90, 0x80] 0+ _ <- testValidateUtf8More s [0x80] 1+ testValidateUtf8MoreFail s [0x7f] (-3)+t_pn_utf8_2 = do+ s0 <- testValidateUtf8 [0xF0] 0+ testValidateUtf8MoreFail s0 [0x7f] (-1)+ s1 <- testValidateUtf8More s0 [0x90] (-1)+ testValidateUtf8MoreFail s1 [0x7f] (-2)+ s2 <- testValidateUtf8More s1 [0x80] (-2)+ testValidateUtf8MoreFail s2 [0x7f] (-3)+ _ <- testValidateUtf8More s2 [0x80] 1+ pure ()+t_pn_utf8_3 = do+ s1 <- testValidateUtf8 [0xc2] 0+ assertBool "PartialUtf8 must be partial" $ B.length (E.getPartialUtf8 s1) < E.getCompleteLen s1+ testValidateUtf8MoreFail s1 [0x80, 0x80] 1++-- Precondition: (i, ms1) = E.validateUtf8More s chunk+--+-- The index points to the end of the longest valid prefix+-- of prechunk `B.append` chunk+pre_validateUtf8More_validPrefix s chunk i =+ let prechunk = E.getPartialUtf8 s in+ -- Note: i <= 0 implies take i = id+ let (j, ms2) = E.validateUtf8Chunk (B.take (B.length prechunk + i) (prechunk `B.append` chunk)) in+ counterexample (show prechunk) $+ (B.length prechunk + i, ms2) === (j, Just E.startUtf8State)++-- Precondition: (i, Nothing) = E.validateUtf8More s chunk+--+-- Appending to an invalid chunk yields another invalid chunk.+pre_validateUtf8More_maximalPrefix s chunk i more =+ E.validateUtf8More s (chunk `B.append` more) === (i, Nothing)++-- Precondition: (i, Just s1) = E.validateUtf8More s chunk+pre_validateUtf8More_suffix s chunk i s1 =+ if 0 <= i+ then B.drop i chunk === p2b s1 -- The state s1 contains a suffix of the chunk.+ else p2b s `B.append` chunk === p2b s1 -- Or the chunk extends the incomplete code point in s1.++-- Precondition: (i, Just s1) = E.validateUtf8More s chunk1+--+-- Validating two chunks sequentially is equivalent to validating them at once.+pre_validateUtf8More_append s chunk1 s1 chunk2 =+ let (j, ms2) = E.validateUtf8More s1 chunk2 in+ (B.length chunk1 + j, ms2) === E.validateUtf8More s (chunk1 `B.append` chunk2)++-- These wrappers use custom generators to satisfy the above properties.++t_validateUtf8More_validPrefix = property $ do+ cex@(s, chunk, i, _ms1) <- randomMoreChunk+ pure $ counterexample (show cex) $+ pre_validateUtf8More_validPrefix s chunk i++t_validateUtf8More_maximalPrefix = property $ do+ -- We want chunks that fail validation: force their size to be big,..+ cex@(s, chunk, i, ms1) <- scale (* 3) arbitraryMoreChunk+ pure $ counterexample (show cex) $+ -- ... and just use rejection sampling+ isNothing ms1 ==>+ pre_validateUtf8More_maximalPrefix s chunk i++t_validateUtf8More_valid = property $ do+ cex@(s, chunk1, i, s1, chunk2) <- validMoreChunks+ pure $ counterexample (show cex) $+ pre_validateUtf8More_suffix s chunk1 i s1 .&&.+ pre_validateUtf8More_append s chunk1 s1 chunk2++randomMoreChunk, arbitraryMoreChunk, validMoreChunk :: Gen (E.Utf8State, B.ByteString, Int, Maybe E.Utf8State)+randomMoreChunk = oneof [arbitraryMoreChunk, validMoreChunk]++arbitraryMoreChunk = do+ s <- randomUtf8State+ chunk <- arbitrary+ let (i, ms1) = E.validateUtf8More s chunk+ pure (s, chunk, i, ms1)++-- | Generate a random state by parsing a prefix of a Char+randomUtf8State :: Gen E.Utf8State+randomUtf8State = do+ c <- arbitrary+ chunk <- elements (B.inits (E.encodeUtf8 (T.singleton c)))+ case E.validateUtf8Chunk chunk of+ (_, Just s) -> pure s+ (_, Nothing) -> error "should not happen"++-- | Make a valid chunk, i.e., (s, chunk) such that+--+-- validateUtf8More s chunk = (i, Just s1)+--+-- Also returning i and s1 to not repeat work.+validMoreChunk = do+ (s, chunk, i, s1, _chunk2) <- validMoreChunks+ pure (s, chunk, i, Just s1)++-- | Make a valid chunk by slicing a valid UTF8 bs,+-- and also provide a second chunk which is a valid extension+-- with 0.5 probability.+validMoreChunks :: Gen (E.Utf8State, B.ByteString, Int, E.Utf8State, B.ByteString)+validMoreChunks = do+ bs <- E.encodeUtf8 <$> scale (* 3) arbitrary+ -- Take an intermediate state.+ -- No need to go too far since code points are at most 4 bytes long+ i <- choose (0, 3)+ let (bs0, bs1) = B.splitAt i bs+ case E.validateUtf8Chunk bs0 of+ (_, Just s) -> do+ j <- choose (0, B.length bs1)+ let (chunk1, chunk2') = B.splitAt j bs1+ case E.validateUtf8More s chunk1 of+ (n1, Just s1) -> do+ chunk2 <- oneof [pure chunk2', arbitrary]+ pure (s, chunk1, n1, s1, chunk2)+ (_, Nothing) -> error "should not happen"+ (_, Nothing) -> error "should not happen"++t_utf8_c = (E.strictBuilderToText . fst3 . E.decodeUtf8Chunk . E.encodeUtf8) `eq` id t_utf8 = (E.decodeUtf8 . E.encodeUtf8) `eq` id t_utf8' = (E.decodeUtf8' . E.encodeUtf8) `eq` (id . Right) tl_utf8 = (EL.decodeUtf8 . EL.encodeUtf8) `eq` id@@ -48,6 +218,9 @@ t_utf32BE = (E.decodeUtf32BE . E.encodeUtf32BE) `eq` id tl_utf32BE = (EL.decodeUtf32BE . EL.encodeUtf32BE) `eq` id +fst3 :: (a, b, c) -> a+fst3 (a, _, _) = a+ runBuilder :: B.Builder -> B.ByteString runBuilder = -- Use smallish buffers to exercise bufferFull case as well@@ -82,7 +255,7 @@ t_utf8_undecoded t = let b = E.encodeUtf8 t ls = concatMap (leftover . E.encodeUtf8 . T.singleton) . T.unpack $ t- leftover = (++ [B.empty]) . init . tail . B.inits+ leftover = (++ [B.empty]) . init . drop 1 . B.inits in (map snd . feedChunksOf 1 E.streamDecodeUtf8) b === ls data InvalidUtf8 = InvalidUtf8@@ -190,26 +363,124 @@ t_decode_with_error4 = E.decodeUtf8With (\_ _ -> Just 'x') (B.pack [0xF0, 97, 97, 97]) === "xaaa" +t_decode_with_error1' = do+ E.Some x1 bs1 f1 <- pure $ E.streamDecodeUtf8With (\_ _ -> Just 'x') (B.pack [0xc2])+ x1 @?= ""+ bs1 @?= B.pack [0xc2]+ E.Some x2 bs2 _ <- pure $ f1 $ B.pack [0x80, 0x80]+ x2 @?= "\x80x"+ bs2 @?= mempty t_decode_with_error2' = case E.streamDecodeUtf8With (\_ _ -> Just 'x') (B.pack [0xC2, 97]) of- E.Some x _ _ -> x === "xa"+ E.Some x _ _ -> x @?= "xa" t_decode_with_error3' = case E.streamDecodeUtf8With (\_ _ -> Just 'x') (B.pack [0xC2, 97, 97]) of- E.Some x _ _ -> x === "xaa"+ E.Some x _ _ -> x @?= "xaa" t_decode_with_error4' = case E.streamDecodeUtf8With (\_ _ -> Just 'x') (B.pack [0xC2, 97, 97, 97]) of- E.Some x _ _ -> x === "xaaa"-t_decode_with_error5' = ioProperty $ do+ E.Some x _ _ -> x @?= "xaaa"+t_decode_with_error5' = do ret <- Exception.try $ Exception.evaluate $ E.streamDecodeUtf8 (B.pack [0x81])- pure $ case ret of- Left (_ :: E.UnicodeException) -> True- Right{} -> False+ case ret of+ Left (_ :: E.UnicodeException) -> pure ()+ Right{} -> assertFailure "Unexpected success" +testDecodeUtf8With :: (Maybe E.Utf8State -> IO r) -> E.Utf8State -> [Word8] -> T.Text -> IO r+testDecodeUtf8With k s xs expected =+ let xs' = B.pack xs in+ case E.decodeUtf8More s xs' of+ (prefix, bs, s') -> do+ let txt = E.strictBuilderToText prefix+ txt @?= expected+ if T.null txt then+ bs @?= xs'+ else+ E.encodeUtf8 txt `B.append` bs @?= E.getPartialUtf8 s `B.append` xs'+ k s'++testDecodeUtf8 :: E.Utf8State -> [Word8] -> T.Text -> IO E.Utf8State+testDecodeUtf8 = testDecodeUtf8With (\ms -> case ms of+ Just s -> pure s+ Nothing -> assertFailure "Unexpected failure")++testDecodeUtf8Fail :: E.Utf8State -> [Word8] -> T.Text -> IO ()+testDecodeUtf8Fail = testDecodeUtf8With (\ms -> case ms of+ Just _ -> assertFailure "Unexpected failure"+ Nothing -> pure ())++t_decode_chunk1 = do+ s1 <- testDecodeUtf8 E.startUtf8State [0xc2] ""+ B.length (E.getPartialUtf8 s1) @?= 1+ testDecodeUtf8Fail s1 [0x80, 0x80] "\128"++t_decode_chunk2 = do+ s1 <- testDecodeUtf8 E.startUtf8State [0xf0] ""+ s2 <- testDecodeUtf8 s1 [0x90, 0x80] ""+ _ <- testDecodeUtf8 s2 [0x80, 0x41] "\65536A"+ pure ()+ t_infix_concat bs1 text bs2 = forAll (Blind <$> genDecodeErr Replace) $ \(Blind onErr) -> text `T.isInfixOf` E.decodeUtf8With onErr (B.concat [bs1, E.encodeUtf8 text, bs2]) +t_textToStrictBuilder =+ (E.strictBuilderToText . E.textToStrictBuilder) `eq` id++-- decodeUtf8Chunk splits the input bytestring+t_decodeUtf8Chunk_split chunk =+ let (pre, suf, _ms) = E.decodeUtf8Chunk chunk+ in s2b pre `B.append` suf === chunk++-- decodeUtf8More mostly splits the input bytestring,+-- also inserting bytes from the partial code point in s.+--+-- This is wrapped by t_decodeUtf8More_split to have more+-- likely valid chunks.+t_decodeUtf8More_split' s chunk =+ let (pre, suf, _ms) = E.decodeUtf8More s chunk+ in if B.length chunk > B.length suf+ then s2b pre `B.append` suf === p2b s `B.append` chunk+ else suf === chunk++-- The output state of decodeUtf8More contains the suffix.+--+-- Precondition (valid chunk): ms = Just s'+pre_decodeUtf8More_suffix s chunk =+ let (_pre, suf, ms) = E.decodeUtf8More s chunk+ in case ms of+ Nothing -> discard+ Just s' -> if B.length chunk > B.length suf+ then p2b s' === suf+ else p2b s' === p2b s `B.append` suf++-- Decoding chunks separately is equivalent to decoding their concatenation.+pre_decodeUtf8More_append s chunk1 chunk2 =+ let (pre1, _, ms1) = E.decodeUtf8More s chunk1 in+ case ms1 of+ Nothing -> discard+ Just s1 ->+ let (pre2, _, ms2) = E.decodeUtf8More s1 chunk2 in+ let (pre3, _, ms3) = E.decodeUtf8More s (chunk1 `B.append` chunk2) in+ (s2b (pre1 <> pre2), ms2) === (s2b pre3, ms3)++-- Properties for any chunk+-- (but do try to generate valid chunks often enough)+t_decodeUtf8More1 = property $ do+ cex@(s, chunk, _, _) <- randomMoreChunk+ pure $ counterexample (show cex) $+ t_decodeUtf8More_split' s chunk++-- Properties that require valid chunks+t_decodeUtf8More2 = property $ do+ cex@(s, chunk, _, _, chunk2) <- validMoreChunks+ pure $ counterexample (show cex) $+ pre_decodeUtf8More_suffix s chunk .&&.+ pre_decodeUtf8More_append s chunk chunk2++s2b = E.encodeUtf8 . E.strictBuilderToText+p2b = E.getPartialUtf8+ testTranscoding :: TestTree testTranscoding = testGroup "transcoding" [@@ -219,8 +490,8 @@ testProperty "tl_latin1" tl_latin1, testProperty "t_utf8" t_utf8, testProperty "t_utf8'" t_utf8',- testProperty "t_utf8_incr" t_utf8_incr, testProperty "t_utf8_undecoded" t_utf8_undecoded,+ testProperty "t_utf8_incr" t_utf8_incr, testProperty "tl_utf8" tl_utf8, testProperty "tl_utf8'" tl_utf8', testProperty "t_utf16LE" t_utf16LE,@@ -247,10 +518,40 @@ testProperty "t_decode_with_error2" t_decode_with_error2, testProperty "t_decode_with_error3" t_decode_with_error3, testProperty "t_decode_with_error4" t_decode_with_error4,- testProperty "t_decode_with_error2'" t_decode_with_error2',- testProperty "t_decode_with_error3'" t_decode_with_error3',- testProperty "t_decode_with_error4'" t_decode_with_error4',- testProperty "t_decode_with_error5'" t_decode_with_error5',+ testCase "t_decode_with_error1'" t_decode_with_error1',+ testCase "t_decode_with_error2'" t_decode_with_error2',+ testCase "t_decode_with_error3'" t_decode_with_error3',+ testCase "t_decode_with_error4'" t_decode_with_error4',+ testCase "t_decode_with_error5'" t_decode_with_error5', testProperty "t_infix_concat" t_infix_concat+ ],+ testGroup "validate" [+ testProperty "t_validateUtf8More_validPrefix" t_validateUtf8More_validPrefix,+ testProperty "t_validateUtf8More_maximalPrefix" t_validateUtf8More_maximalPrefix,+ testProperty "t_validateUtf8More_valid" t_validateUtf8More_valid+ ],+ testGroup "streaming" [+ testProperty "t_utf8_c" t_utf8_c,+ testCase "t_p_utf8_1" t_p_utf8_1,+ testCase "t_p_utf8_2" t_p_utf8_2,+ testCase "t_p_utf8_3" t_p_utf8_3,+ testCase "t_p_utf8_4" t_p_utf8_4,+ testCase "t_p_utf8_5" t_p_utf8_5,+ testCase "t_p_utf8_6" t_p_utf8_6,+ testCase "t_p_utf8_7" t_p_utf8_7,+ testCase "t_p_utf8_8" t_p_utf8_8,+ testCase "t_p_utf8_9" t_p_utf8_9,+ testCase "t_p_utf8_0" t_p_utf8_0,+ testCase "t_pn_utf8_1" t_pn_utf8_1,+ testCase "t_pn_utf8_2" t_pn_utf8_2,+ testCase "t_pn_utf8_3" t_pn_utf8_3,+ testCase "t_decode_chunk1" t_decode_chunk1,+ testCase "t_decode_chunk2" t_decode_chunk2,+ testProperty "t_decodeUtf8Chunk_split" t_decodeUtf8Chunk_split,+ testProperty "t_decodeUtf8More1" t_decodeUtf8More1,+ testProperty "t_decodeUtf8More2" t_decodeUtf8More2+ ],+ testGroup "strictBuilder" [+ testProperty "textToStrictBuilder" t_textToStrictBuilder ] ]
text.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: text-version: 2.0.1+version: 2.0.2 homepage: https://github.com/haskell/text bug-reports: https://github.com/haskell/text/issues@@ -46,14 +46,14 @@ category: Data, Text build-type: Simple tested-with:- GHC == 8.0.2 GHC == 8.2.2 GHC == 8.4.4 GHC == 8.6.5 GHC == 8.8.4 GHC == 8.10.7- GHC == 9.0.1- GHC == 9.2.1+ GHC == 9.0.2+ GHC == 9.2.4+ GHC == 9.4.1 extra-source-files: -- scripts/CaseFolding.txt@@ -116,7 +116,7 @@ -- Certain version of GHC crash on Windows, when TemplateHaskell encounters C++. -- https://gitlab.haskell.org/ghc/ghc/-/issues/19417- if flag(simdutf) && os(windows) && impl(ghc == 8.0.1 || >= 8.8 && < 8.10.5 || == 9.0.1)+ if flag(simdutf) && os(windows) && impl(ghc >= 8.8 && < 8.10.5 || == 9.0.1) build-depends: base < 0 -- For GHC 8.2, 8.6.3 and 8.10.1 even TH + C crash Windows linker.@@ -131,6 +131,11 @@ if (arch(aarch64) || arch(arm)) && impl(ghc == 9.2.1) build-depends: base < 0 + -- NetBSD + GHC 9.2.1 + TH + C++ does not work together.+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/22577+ if flag(simdutf) && os(netbsd) && impl(ghc < 9.4)+ build-depends: base < 0+ exposed-modules: Data.Text Data.Text.Array@@ -145,6 +150,7 @@ Data.Text.Internal.Builder.RealFloat.Functions Data.Text.Internal.ByteStringCompat Data.Text.Internal.PrimCompat+ Data.Text.Internal.Encoding Data.Text.Internal.Encoding.Fusion Data.Text.Internal.Encoding.Fusion.Common Data.Text.Internal.Encoding.Utf16@@ -163,6 +169,7 @@ Data.Text.Internal.Private Data.Text.Internal.Read Data.Text.Internal.Search+ Data.Text.Internal.StrictBuilder Data.Text.Internal.Unsafe Data.Text.Internal.Unsafe.Char Data.Text.Lazy@@ -181,12 +188,12 @@ build-depends: array >= 0.3 && < 0.6,- base >= 4.9 && < 5,+ 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.10,- template-haskell >= 2.5 && < 2.20+ ghc-prim >= 0.2 && < 0.11,+ template-haskell >= 2.5 && < 2.21 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 if flag(developer)@@ -260,9 +267,9 @@ transformers, text - -- Plugin infrastructure does not work properly in 8.0.1 and 8.6.1, and+ -- Plugin infrastructure does not work properly in 8.6.1, and -- ghc-9.2.1 library depends on parsec, which causes a circular dependency.- if impl(ghc >= 8.0.2 && < 8.6 || >= 8.6.2 && < 9.2 || >= 9.2.2)+ if impl(ghc >= 8.2.1 && < 8.6 || >= 8.6.2 && < 9.2 || >= 9.2.2) build-depends: tasty-inspection-testing default-language: Haskell2010@@ -276,6 +283,8 @@ ghc-options: "-with-rtsopts=-A32m --nonmoving-gc" else ghc-options: "-with-rtsopts=-A32m"+ if impl(ghc >= 8.6)+ ghc-options: -fproc-alignment=64 build-depends: base, bytestring >= 0.10.4,