packages feed

text 2.1 → 2.1.1

raw patch · 26 files changed

+986/−412 lines, 26 filesdep ~QuickCheckdep ~ghc-primdep ~template-haskell

Dependency ranges changed: QuickCheck, ghc-prim, template-haskell

Files

cbits/measure_off.c view
@@ -70,6 +70,9 @@   while (src < srcend - 7){     uint64_t w64;     memcpy(&w64, src, sizeof(uint64_t));+    // find leading bytes by finding every byte that is not a continuation+    // byte. The bit twiddle only results in a 0 if the original byte starts+    // with 0b11...     w64 =  ((w64 << 1) | ~w64) & 0x8080808080808080ULL;     // compute the popcount of w64 with two bit shifts and a multiplication     size_t leads = (  (w64 >> 7)              // w64 >> 7           = Sum{0<= i <= 7} x_i * 256^i    (x_i \in {0,1})
changelog.md view
@@ -1,3 +1,18 @@+### 2.1.1++* Add pure Haskell implementations as an alternative to C-based ones,+  suitable for JavaScript backend.++* [Add type synonyms for lazy and strict text flavours](https://github.com/haskell/text/pull/547)++* [Share empty `Text` values](https://github.com/haskell/text/pull/493)++* [Fix bug in `isValidUtf8ByteArray`](https://github.com/haskell/text/pull/553)++* [Optimize the implementation of `Data.Text.concat`](https://github.com/haskell/text/pull/551)++* [Fix `filter/filter` rules for `Text` and lazy `Text`](https://github.com/haskell/text/pull/560)+ ### 2.1  * [Switch `Data.Text.Array` to `Data.Array.Byte`](https://github.com/haskell/text/pull/474)
− scripts/CaseFoldExceptions.hs 
@@ -1,17 +0,0 @@--- Generates exceptions for tests/Tests/Properties/Text.hs--- runghc CaseFoldExceptions.txt--import qualified Data.Char-import Data.List-import qualified Data.Text as T--toCaseFoldExceptions :: String-toCaseFoldExceptions = filter (\c -> c `notElem` (cherokeeUpper ++ cherokeeLower)) $-   filter (\c -> T.toCaseFold (T.singleton c) /= T.singleton (Data.Char.toLower c))-     [minBound .. maxBound]--cherokeeUpper = ['\x13A0'..'\x13F7'] -- x13F8..13FF are lowercase-cherokeeLower = ['\xAB70'..'\xABBF']--main :: IO ()-main = print toCaseFoldExceptions
src/Data/Text.hs view
@@ -53,6 +53,7 @@      -- * Types       Text+    , StrictText      -- * Creation and elimination     , pack@@ -213,47 +214,50 @@                 Eq, (==), (/=), Ord(..), Ordering(..), (++),                 Monad(..), pure, Read(..),                 (&&), (||), (+), (-), (.), ($), ($!), (>>),-                not, return, otherwise, quot, IO)+                not, return, otherwise, quot) import Control.DeepSeq (NFData(rnf)) #if defined(ASSERTS) import Control.Exception (assert) #endif-import Data.Bits ((.&.), shiftR, shiftL)+import Data.Bits ((.&.)) 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 hiding (head, tail) import Data.Binary (Binary(get, put)) 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 Data.Text.Internal.ArrayUtils (memchr)+import Data.Text.Internal.IsAscii (isAscii)+import Data.Text.Internal.Reverse (reverse)+import Data.Text.Internal.Measure (measure_off)+import Data.Text.Internal.Encoding.Utf8 (utf8Length, utf8LengthByLeader, chr3, 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, pack)-import Data.Text.Internal.Unsafe.Char (unsafeWrite, unsafeChr8)+import Data.Text.Internal (Text(..), StrictText, empty, firstf, mul, safe, text, append, pack)+import Data.Text.Internal.Unsafe.Char (unsafeWrite) 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, iterArray, reverseIterArray) import Data.Text.Internal.Search (indices)+import Data.Text.Internal.Transformation (mapNonEmpty, toCaseFoldNonEmpty, toLowerNonEmpty, toUpperNonEmpty, filter_) #if defined(__HADDOCK__) import Data.ByteString (ByteString) import qualified Data.Text.Lazy as L #endif import Data.Word (Word8) import Foreign.C.Types-import GHC.Base (eqInt, neInt, gtInt, geInt, ltInt, leInt, ByteArray#)+import GHC.Base (eqInt, neInt, gtInt, geInt, ltInt, leInt) import qualified GHC.Exts as Exts-import GHC.Int (Int8, Int64(..))+import GHC.Int (Int8) import GHC.Stack (HasCallStack) import qualified Language.Haskell.TH.Lib as TH import qualified Language.Haskell.TH.Syntax as TH@@ -418,10 +422,14 @@ #if MIN_VERSION_template_haskell(2,16,0)   lift txt = do     let (ptr, len) = unsafePerformIO $ asForeignPtr txt-        bytesQ = TH.litE . TH.bytesPrimL $ TH.mkBytes ptr 0 (P.fromIntegral len)-        lenQ = liftInt (P.fromIntegral len)-        liftInt n = (TH.appE (TH.conE 'Exts.I#) (TH.litE (TH.IntPrimL n)))-    TH.varE 'unpackCStringLen# `TH.appE` bytesQ `TH.appE` lenQ+    case len of+        0 -> TH.varE 'empty+        _ ->+          let+            bytesQ = TH.litE . TH.bytesPrimL $ TH.mkBytes ptr 0 (P.fromIntegral len)+            lenQ = liftInt (P.fromIntegral len)+            liftInt n = (TH.appE (TH.conE 'Exts.I#) (TH.litE (TH.IntPrimL n)))+          in TH.varE 'unpackCStringLen# `TH.appE` bytesQ `TH.appE` lenQ #else   lift = TH.appE (TH.varE 'pack) . TH.stringE . unpack #endif@@ -499,7 +507,7 @@ -- non-empty. This is a partial function, consider using 'unsnoc' instead. last :: HasCallStack => Text -> Char last t@(Text _ _ len)-    | len <= 0  = emptyError "last"+    | null t = emptyError "last"     | otherwise = let Iter c _ = reverseIter t (len - 1) in c {-# INLINE [1] last #-} @@ -507,7 +515,7 @@ -- must be non-empty. This is a partial function, consider using 'uncons' instead. tail :: HasCallStack => Text -> Text tail t@(Text arr off len)-    | len <= 0  = emptyError "tail"+    | null t = emptyError "tail"     | otherwise = text arr (off+d) (len-d)     where d = iter_ t 0 {-# INLINE [1] tail #-}@@ -516,7 +524,7 @@ -- be non-empty. This is a partial function, consider using 'unsnoc' instead. init :: HasCallStack => Text -> Text init t@(Text arr off len)-    | len <= 0  = emptyError "init"+    | null t = emptyError "init"     | otherwise = text arr off (len + reverseIter_ t (len - 1)) {-# INLINE [1] init #-} @@ -526,7 +534,7 @@ -- @since 1.2.3.0 unsnoc :: Text -> Maybe (Text, Char) unsnoc t@(Text arr off len)-    | len <= 0  = Nothing+    | null t = Nothing     | otherwise = Just (text arr off (len + d), c)         where             Iter c d = reverseIter t (len - 1)@@ -541,6 +549,10 @@     len <= 0 {-# INLINE [1] null #-} +{-# RULES + "TEXT null/empty -> True" null empty = True+#-}+ -- | /O(1)/ Tests whether a 'Text' contains exactly one character. isSingleton :: Text -> Bool isSingleton = S.isSingleton . stream@@ -576,6 +588,8 @@     length (intersperse c t) = max 0 (mul 2 (length t) - 1) "TEXT length/intercalate -> n*length" forall s ts.     length (intercalate s ts) = let lenS = length s in max 0 (P.sum (P.map (\t -> length t + lenS) ts) - lenS)+"TEXT length/empty -> 0"+    length empty = 0   #-}  -- | /O(min(n,c))/ Compare the count of characters in a 'Text' to a number.@@ -639,28 +653,7 @@ -- -- Performs replacement on invalid scalar values. map :: (Char -> Char) -> Text -> Text-map f = go-  where-    go (Text src o l) = runST $ do-      marr <- A.new (l + 4)-      outer marr (l + 4) o 0-      where-        outer :: forall s. A.MArray s -> Int -> Int -> Int -> ST s Text-        outer !dst !dstLen = inner-          where-            inner !srcOff !dstOff-              | srcOff >= l + o = do-                A.shrinkM dst dstOff-                arr <- A.unsafeFreeze dst-                return (Text arr 0 dstOff)-              | dstOff + 4 > dstLen = do-                let !dstLen' = dstLen + (l + o) - srcOff + 4-                dst' <- A.resizeM dst dstLen'-                outer dst' dstLen' srcOff dstOff-              | otherwise = do-                let !(Iter c d) = iterArray src srcOff-                d' <- unsafeWrite dst dstOff (safe (f c))-                inner (srcOff + d) (dstOff + d')+map f = \t -> if null t then empty else mapNonEmpty f t {-# INLINE [1] map #-}  {-# RULES@@ -690,7 +683,7 @@ -- -- Performs replacement on invalid scalar values. intersperse :: Char -> Text -> Text-intersperse c t@(Text src o l) = if l == 0 then mempty else runST $ do+intersperse c t@(Text src o l) = if null t then empty else runST $ do     let !cLen = utf8Length c         dstLen = l + length t P.* cLen @@ -746,29 +739,6 @@     return (Text arr 0 (dstLen - cLen)) {-# INLINE [1] intersperse #-} --- | /O(n)/ Reverse the characters of a string.------ Example:------ >>> T.reverse "desrever"--- "reversed"-reverse ::-#if defined(ASSERTS)-  HasCallStack =>-#endif-  Text -> Text-reverse (Text (A.ByteArray ba) off len) = runST $ do-    marr@(A.MutableByteArray mba) <- A.new len-    unsafeIOToST $ c_reverse mba ba (intToCSize off) (intToCSize len)-    brr <- A.unsafeFreeze marr-    return $ Text brr 0 len-{-# INLINE reverse #-}---- | The input buffer (src :: ByteArray#, off :: CSize, len :: CSize)--- must specify a valid UTF-8 sequence, this condition is not checked.-foreign import ccall unsafe "_hs_text_reverse" c_reverse-    :: Exts.MutableByteArray# s -> ByteArray# -> CSize -> CSize -> IO ()- -- | /O(m+n)/ Replace every non-overlapping occurrence of @needle@ in -- @haystack@ with @replacement@. --@@ -807,9 +777,9 @@                (Text repArr repOff repLen)       haystack@(Text hayArr hayOff hayLen)   | neeLen == 0 = emptyError "replace"+  | len == 0 = empty -- if also haystack is empty, we can't just return 'haystack' as worker/wrapper might duplicate it   | L.null ixs  = haystack-  | len > 0     = Text (A.run x) 0 len-  | otherwise   = empty+  | otherwise   = Text (A.run x) 0 len   where     ixs = indices needle haystack     len = hayLen - (neeLen - repLen) `mul` L.length ixs@@ -846,84 +816,6 @@ -- 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@@ -941,7 +833,9 @@ -- U+00B5) is case folded to \"&#x3bc;\" (small letter mu, U+03BC) -- instead of itself. toCaseFold :: Text -> Text-toCaseFold = \xs -> caseConvert (\w -> if w - 65 <= 25 then w + 32 else w) foldMapping xs+toCaseFold = \t ->+    if null t then empty+    else toCaseFoldNonEmpty t {-# INLINE toCaseFold #-}  -- | /O(n)/ Convert a string to lower case, using simple case@@ -952,7 +846,9 @@ -- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069) -- followed by \" &#x307;\" (combining dot above, U+0307). toLower :: Text -> Text-toLower = \xs -> caseConvert (\w -> if w - 65 <= 25 then w + 32 else w) lowerMapping xs+toLower = \t ->+  if null t then empty+  else toLowerNonEmpty t {-# INLINE toLower #-}  -- | /O(n)/ Convert a string to upper case, using simple case@@ -962,7 +858,9 @@ -- instance, the German \"&#xdf;\" (eszett, U+00DF) maps to the -- two-letter sequence \"SS\". toUpper :: Text -> Text-toUpper = \xs -> caseConvert (\w -> if w - 97 <= 25 then w - 32 else w) upperMapping xs+toUpper = \t ->+  if null t then empty+  else toUpperNonEmpty t {-# INLINE toUpper #-}  -- | /O(n)/ Convert a string to title case, using simple case@@ -1136,18 +1034,18 @@  -- | /O(n)/ Concatenate a list of 'Text's. concat :: [Text] -> Text-concat ts = case ts' of-              [] -> empty-              [t] -> t-              _ -> Text (A.run go) 0 len+concat ts = case ts of+    [] -> empty+    [t] -> t+    _ | len == 0 -> empty+      | otherwise -> Text (A.run go) 0 len   where-    ts' = L.filter (not . null) ts-    len = sumP "concat" $ L.map lengthWord8 ts'+    len = sumP "concat" $ L.map lengthWord8 ts     go :: ST s (A.MArray s)     go = do       arr <- A.new len       let step i (Text a o l) = A.copyI l arr i a o >> return (i + l)-      foldM step 0 ts' >> return arr+      foldM step 0 ts >> return arr  -- | /O(n)/ Map a function over a 'Text' that results in a 'Text', and -- concatenate the results.@@ -1179,35 +1077,6 @@ 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@@ -1393,8 +1262,10 @@ take :: Int -> Text -> Text take n t@(Text arr off len)     | n <= 0    = empty-    | n >= len  = t-    | otherwise = let m = measureOff n t in if m >= 0 then text arr off m else t+    | n >= len || m >= len || m < 0  = t+    | otherwise = Text arr off m +  where+    m = measureOff n t {-# INLINE [1] take #-}  -- | /O(n)/ If @t@ is long enough to contain @n@ characters, 'measureOff' @n@ @t@@@ -1409,12 +1280,7 @@ measureOff :: Int -> Text -> Int measureOff !n (Text (A.ByteArray arr) off len) = if len == 0 then 0 else   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 -> CSsize+    measure_off arr (intToCSize off) (intToCSize len) (intToCSize n)  -- | /O(n)/ 'takeEnd' @n@ @t@ returns the suffix remaining after -- taking @n@ characters from the end of @t@.@@ -1446,8 +1312,8 @@ drop :: Int -> Text -> Text drop n t@(Text arr off len)     | n <= 0    = t-    | n >= len  = empty-    | otherwise = if m >= 0 then text arr (off+m) (len-m) else mempty+    | n >= len || m >= len || m < 0 = empty+    | otherwise = Text arr (off+m) (len-m)    where m = measureOff n t {-# INLINE [1] drop #-} @@ -1555,9 +1421,10 @@ splitAt :: Int -> Text -> (Text, Text) splitAt n t@(Text arr off len)     | n <= 0    = (empty, t)-    | n >= len  = (t, empty)-    | otherwise = let m = measureOff n t in-    if m >= 0 then (text arr off m, text arr (off+m) (len-m)) else (t, mempty)+    | n >= len || m >= len || m < 0  = (t, empty)+    | otherwise = (Text arr off m, Text arr (off+m) (len-m)) +  where+    m = measureOff n t  -- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns -- a pair whose first element is the longest prefix (possibly empty)@@ -1655,9 +1522,11 @@ -- | /O(n)/ Return all initial segments of the given 'Text', shortest -- first. inits :: Text -> [Text]-inits t@(Text arr off len) = loop 0-    where loop i | i >= len = [t]-                 | otherwise = Text arr off i : loop (i + iter_ t i)+inits t = empty : case t of+  Text arr off len ->+    let loop i | i >= len = []+               | otherwise = let !j = i + iter_ t i in Text arr off j : loop j+    in loop 0  -- | /O(n)/ Return all final segments of the given 'Text', longest -- first.@@ -1727,8 +1596,9 @@ -- >>> split (=='a') "" -- [""] split :: (Char -> Bool) -> Text -> [Text]-split _ t@(Text _off _arr 0) = [t]-split p t = loop t+split p t+    | null t = [empty]+    | otherwise = loop t     where loop s | null s'   = [l]                  | otherwise = l : loop (unsafeTail s')               where (# l, s' #) = span_ (not . p) s@@ -1784,72 +1654,12 @@ -- returns a 'Text' containing those characters that satisfy the -- predicate. filter :: (Char -> Bool) -> Text -> Text-filter p = go-  where-    go (Text src o l) = runST $ do-      -- It's tempting to allocate l elements at once and avoid resizing.-      -- However, this can be unacceptable in scenarios where a huge array-      -- is filtered with a rare predicate, resulting in a much shorter buffer.-      let !dstLen = min l 64-      dst <- A.new dstLen-      outer dst dstLen 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 + 4 > dstLen = do-                -- Double size of the buffer, unless it becomes longer than-                -- source string. Ensure to extend it by least 4 bytes.-                let !dstLen' = dstLen + max 4 (min (l + o - srcOff) dstLen)-                dst' <- A.resizeM dst dstLen'-                outer dst' dstLen' srcOff dstOff-              -- In case of success, filter writes exactly the same character-              -- it just read (this is not a case for map, for example).-              -- We leverage this fact below: 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-                    let !c = unsafeChr8 m0-                    if not (p c) then inner (srcOff + 1) dstOff else do-                      A.unsafeWrite dst dstOff m0-                      inner (srcOff + 1) (dstOff + 1)-                  2 -> do-                    let !c = chr2 m0 m1-                    if not (p c) then inner (srcOff + 2) dstOff else do-                      A.unsafeWrite dst dstOff m0-                      A.unsafeWrite dst (dstOff + 1) m1-                      inner (srcOff + 2) (dstOff + 2)-                  3 -> do-                    let !c = chr3 m0 m1 m2-                    if not (p c) then inner (srcOff + 3) dstOff else do-                      A.unsafeWrite dst dstOff m0-                      A.unsafeWrite dst (dstOff + 1) m1-                      A.unsafeWrite dst (dstOff + 2) m2-                      inner (srcOff + 3) (dstOff + 3)-                  _ -> do-                    let !c = chr4 m0 m1 m2 m3-                    if not (p c) then inner (srcOff + 4) dstOff else do-                      A.unsafeWrite dst dstOff m0-                      A.unsafeWrite dst (dstOff + 1) m1-                      A.unsafeWrite dst (dstOff + 2) m2-                      A.unsafeWrite dst (dstOff + 3) m3-                      inner (srcOff + 4) (dstOff + 4)+filter p = filter_ text p {-# INLINE [1] filter #-}  {-# RULES "TEXT filter/filter -> filter" forall p q t.-    filter p (filter q t) = filter (\c -> p c && q c) t+    filter p (filter q t) = filter (\c -> q c && p c) t #-}  -- | /O(n+m)/ Find the first instance of @needle@ (which must be@@ -2055,13 +1865,9 @@       | delta < 0 = [Text arr n (len + off - n)]       | otherwise = Text arr n delta : go (n + delta + 1)       where-        delta = cSsizeToInt $-          memchr arr# (intToCSize n) (intToCSize (len + off - n)) 0x0A+        delta = memchr arr# n (len + off - n) 0x0A {-# INLINE lines #-} -foreign import ccall unsafe "_hs_text_memchr" memchr-    :: ByteArray# -> CSize -> CSize -> Word8 -> CSsize- -- | /O(n)/ Joins lines, after appending a terminating newline to -- each. unlines :: [Text] -> Text@@ -2206,12 +2012,12 @@  -- | Add a list of non-negative numbers.  Errors out on overflow. sumP :: String -> [Int] -> Int-sumP fun = go 0-  where go !a (x:xs)-            | ax >= 0   = go ax xs+sumP fun = L.foldl' add 0+  where add a x+            | ax >= 0   = ax             | otherwise = overflowError fun           where ax = a + x-        go a  _         = a+{-# INLINE sumP #-} -- Use foldl' and inline for fusion.  emptyError :: HasCallStack => String -> a emptyError fun = P.error $ "Data.Text." ++ fun ++ ": empty input"@@ -2228,7 +2034,9 @@ -- copy \"breaks the link\" to the original array, allowing it to be -- garbage collected if there are no other live references to it. copy :: Text -> Text-copy (Text arr off len) = Text (A.run go) 0 len+copy t@(Text arr off len)+  | null t = empty+  | otherwise = Text (A.run go) 0 len   where     go :: ST s (A.MArray s)     go = do
src/Data/Text/Encoding.hs view
@@ -85,21 +85,30 @@     ) where  import Control.Exception (evaluate, try)+import Data.Word (Word8)+import GHC.Exts (byteArrayContents#, unsafeCoerce#)+import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(PlainPtr))+import Data.ByteString (ByteString)+#if defined(PURE_HASKELL)+import Control.Monad.ST.Unsafe (unsafeSTToIO)+import Data.ByteString.Char8 (unpack)+import Data.Text.Internal (pack)+import Foreign.Ptr (minusPtr, plusPtr)+import Foreign.Storable (poke)+#else import Control.Monad.ST (runST) import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO) import Data.Bits (shiftR, (.&.))-import Data.Word (Word8)+import Data.Text.Internal.ByteStringCompat (withBS)+import Data.Text.Internal.Unsafe (unsafeWithForeignPtr) 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)+#endif 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.Internal.IsAscii (asciiPrefixLength) import Data.Text.Unsafe (unsafeDupablePerformIO) import Data.Text.Show () import qualified Data.ByteString as B@@ -172,12 +181,6 @@     (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@@ -219,6 +222,9 @@   HasCallStack => #endif   ByteString -> Text+#if defined(PURE_HASKELL)+decodeLatin1 bs = pack (Data.ByteString.Char8.unpack bs)+#else 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@@ -238,9 +244,12 @@   dst' <- A.resizeM dst actualLen   arr <- A.unsafeFreeze dst'   return $ Text arr 0 actualLen+#endif +#if !defined(PURE_HASKELL) foreign import ccall unsafe "_hs_text_is_ascii" c_is_ascii     :: Ptr Word8 -> Ptr Word8 -> IO CSize+#endif  -- $stream --
src/Data/Text/Foreign.hs view
@@ -71,6 +71,7 @@ fromPtr :: Ptr Word8           -- ^ source array         -> I8                  -- ^ length of source array (in 'Word8' units)         -> IO Text+fromPtr _   (I8 0)   = pure empty fromPtr ptr (I8 len) = unsafeSTToIO $ do   dst <- A.new len   A.copyFromPointer dst 0 ptr len
src/Data/Text/Internal.hs view
@@ -29,6 +29,7 @@     -- * Types     -- $internals       Text(..)+    , StrictText     -- * Construction     , text     , textP@@ -36,7 +37,6 @@     , safe     -- * Code that must be here for accessibility     , empty-    , empty_     , append     -- * Utilities     , firstf@@ -68,6 +68,9 @@     {-# UNPACK #-} !Int     -- ^ length in bytes (not in Char!), pointing to an end of UTF-8 sequence     deriving (Typeable) +-- | Type synonym for the strict flavour of 'Text'.+type StrictText = Text+ -- | Smart constructor. text_ :: #if defined(ASSERTS)@@ -90,12 +93,7 @@ -- | /O(1)/ The empty 'Text'. empty :: Text empty = Text A.empty 0 0-{-# INLINE [1] empty #-}---- | A non-inlined version of 'empty'.-empty_ :: Text-empty_ = Text A.empty 0 0-{-# NOINLINE empty_ #-}+{-# NOINLINE empty #-}  -- | /O(n)/ Appends one 'Text' to the other by copying both of them -- into a new 'Text'.@@ -117,6 +115,7 @@  -- | Construct a 'Text' without invisibly pinning its byte array in -- memory if its length has dwindled to zero.+-- It ensures that empty 'Text' values are shared. text :: #if defined(ASSERTS)   HasCallStack =>@@ -127,7 +126,7 @@   -> Text text arr off len | len == 0  = empty                  | otherwise = text_ arr off len-{-# INLINE text #-}+{-# INLINE [0] text #-}  textP :: A.Array -> Int -> Int -> Text {-# DEPRECATED textP "Use text instead" #-}@@ -247,6 +246,7 @@ -- >>> Data.Text.unpack (pack "\55555") -- "\65533" pack :: String -> Text+pack [] = empty 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,
+ src/Data/Text/Internal/ArrayUtils.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE CPP #-}++module Data.Text.Internal.ArrayUtils (memchr) where++#if defined(PURE_HASKELL)+import qualified Data.Text.Array as A+import Data.List (elemIndex)+#else+import Foreign.C.Types+import System.Posix.Types (CSsize(..))+#endif+import GHC.Exts (ByteArray#)+import Data.Word (Word8)++memchr :: ByteArray# -> Int -> Int -> Word8 -> Int+#if defined(PURE_HASKELL)+memchr arr# off len w =+    let tempBa = A.ByteArray arr#+    in case elemIndex w (A.toList tempBa off len) of+        Nothing -> -1+        Just i -> i+#else+memchr arr# off len w = fromIntegral $ c_memchr arr# (intToCSize off) (intToCSize len) w++intToCSize :: Int -> CSize+intToCSize = fromIntegral+++foreign import ccall unsafe "_hs_text_memchr" c_memchr+    :: ByteArray# -> CSize -> CSize -> Word8 -> CSsize+#endif
src/Data/Text/Internal/Encoding.hs view
@@ -244,8 +244,10 @@ {-# INLINE validateUtf8ChunkFrom #-} validateUtf8ChunkFrom :: forall r. Int -> ByteString -> (Int -> Maybe Utf8State -> r) -> r validateUtf8ChunkFrom ofs bs k-  -- B.isValidUtf8 is buggy before bytestring-0.11.5.0-#if defined(SIMDUTF) || MIN_VERSION_bytestring(0,11,5)+  -- B.isValidUtf8 is buggy before bytestring-0.11.5.3 / bytestring-0.12.1.0.+  -- MIN_VERSION_bytestring does not allow us to differentiate+  -- between 0.11.5.2 and 0.11.5.3 so no choice except demanding 0.12.1+.+#if defined(SIMDUTF) || MIN_VERSION_bytestring(0,12,1)   | guessUtf8Boundary > 0 &&     -- the rest of the bytestring is valid utf-8 up to the boundary     (
+ src/Data/Text/Internal/IsAscii.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE UnliftedFFITypes #-}+#if defined(PURE_HASKELL)+{-# LANGUAGE BangPatterns #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}++-- | Implements 'isAscii', using efficient C routines by default.+--+-- Similarly implements asciiPrefixLength, used internally in Data.Text.Encoding.+module Data.Text.Internal.IsAscii where++#if defined(PURE_HASKELL)+import Prelude hiding (all)+import qualified Data.Char as Char+import qualified Data.ByteString as BS+import Data.Text.Unsafe (iter, Iter(..))+#else+import Data.Text.Internal.ByteStringCompat (withBS)+import Data.Text.Internal.Unsafe (unsafeWithForeignPtr)+import Data.Text.Unsafe (unsafeDupablePerformIO)+import Data.Word (Word8)+import Foreign.C.Types+import Foreign.Ptr (Ptr, plusPtr)+import GHC.Base (ByteArray#)+import Prelude (Bool(..), Int, (==), ($), IO, (<$>))+import qualified Data.Text.Array as A+#endif+import Data.ByteString (ByteString)+import Data.Text.Internal (Text(..))+import qualified Prelude as P++-- | \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+#if defined(PURE_HASKELL)+isAscii = all Char.isAscii++-- | (Re)implemented to avoid circular dependency on Data.Text.+all :: (Char -> Bool) -> Text -> Bool+all p t@(Text _ _ len) = go 0+  where+    go i | i >= len = True+         | otherwise =+             let !(Iter c j) = iter t i+             in p c && go (i+j)+#else+cSizeToInt :: CSize -> Int+cSizeToInt = P.fromIntegral+{-# INLINE cSizeToInt #-}++intToCSize :: Int -> CSize+intToCSize = P.fromIntegral++isAscii (Text (A.ByteArray arr) off len) =+    cSizeToInt (c_is_ascii_offset arr (intToCSize off) (intToCSize len)) == len+#endif+{-# INLINE isAscii #-}++-- | Length of the longest ASCII prefix.+asciiPrefixLength :: ByteString -> Int+#if defined(PURE_HASKELL)+asciiPrefixLength = BS.length P.. BS.takeWhile (P.< 0x80)+#else+asciiPrefixLength bs = unsafeDupablePerformIO $ withBS bs $ \ fp len ->+  unsafeWithForeignPtr fp $ \src -> do+    P.fromIntegral <$> c_is_ascii src (src `plusPtr` len)+#endif+{-# INLINE asciiPrefixLength #-}++#if !defined(PURE_HASKELL)+foreign import ccall unsafe "_hs_text_is_ascii_offset" c_is_ascii_offset+    :: ByteArray# -> CSize -> CSize -> CSize++foreign import ccall unsafe "_hs_text_is_ascii" c_is_ascii+    :: Ptr Word8 -> Ptr Word8 -> IO CSize+#endif
src/Data/Text/Internal/Lazy.hs view
@@ -21,6 +21,7 @@ module Data.Text.Internal.Lazy     (       Text(..)+    , LazyText     , chunk     , empty     , foldrChunks@@ -46,11 +47,15 @@ import Foreign.Storable (sizeOf) import qualified Data.Text.Array as A import qualified Data.Text.Internal as T+import qualified Data.Text as T  data Text = Empty           | Chunk {-# UNPACK #-} !T.Text Text             deriving (Typeable) +-- | Type synonym for the lazy flavour of 'Text'.+type LazyText = Text+ -- $invariant -- -- The data type invariant for lazy 'Text': Every 'Text' is either 'Empty' or@@ -82,9 +87,16 @@  -- | Smart constructor for 'Chunk'. Guarantees the data type invariant. chunk :: T.Text -> Text -> Text-{-# INLINE chunk #-}-chunk t@(T.Text _ _ len) ts | len == 0 = ts-                            | otherwise = Chunk t ts+{-# INLINE [0] chunk #-}+chunk t ts | T.null t = ts+           | otherwise = Chunk t ts++{-# RULES+"TEXT chunk/text" forall arr off len.+    chunk (T.text arr off len) = chunk (T.Text arr off len)+"TEXT chunk/empty" forall ts.+    chunk T.empty ts = ts+#-}  -- | Smart constructor for 'Empty'. empty :: Text
src/Data/Text/Internal/Lazy/Search.hs view
@@ -24,18 +24,15 @@       indices     ) where -import Data.Bits (unsafeShiftL)+import Data.Bits (unsafeShiftL, (.|.), (.&.)) import qualified Data.Text.Array as A import Data.Int (Int64) import Data.Word (Word8, Word64) import qualified Data.Text.Internal as T import qualified Data.Text as T (concat, isPrefixOf)+import Data.Text.Internal.ArrayUtils (memchr) import Data.Text.Internal.Fusion.Types (PairS(..)) import Data.Text.Internal.Lazy (Text(..), foldrChunks)-import Data.Bits ((.|.), (.&.))-import Foreign.C.Types-import GHC.Exts (ByteArray#)-import System.Posix.Types (CSsize(..))  -- | /O(n+m)/ Find the offsets of all non-overlapping indices of -- @needle@ within @haystack@.@@ -66,9 +63,9 @@          delta | nextInPattern = nlen + 1                | c == z        = skip + 1                | l >= i + nlen = case-                  memchr xarr# (intToCSize (xoff + i + nlen)) (intToCSize (l - i - nlen)) z of+                  memchr xarr# (xoff + i + nlen) (l - i - nlen) z of                     -1 -> max 1 (l - i - nlen)-                    s  -> cSsizeToInt s + 1+                    s  -> s + 1                 | otherwise = 1          nextInPattern         = mask .&. swizzle (index xxs (i + nlen)) == 0 @@ -133,12 +130,3 @@  word8ToInt :: Word8 -> Int word8ToInt = fromIntegral--intToCSize :: Int -> CSize-intToCSize = fromIntegral--cSsizeToInt :: CSsize -> Int-cSsizeToInt = fromIntegral--foreign import ccall unsafe "_hs_text_memchr" memchr-    :: ByteArray# -> CSize -> CSize -> Word8 -> CSsize
+ src/Data/Text/Internal/Measure.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}++#if defined(PURE_HASKELL)+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiWayIf #-}+#endif++#if !defined(PURE_HASKELL)+{-# LANGUAGE UnliftedFFITypes #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}++-- | Implements 'measure_off', using efficient C routines by default.+module Data.Text.Internal.Measure+  ( measure_off+  )+where++import GHC.Exts++#if defined(PURE_HASKELL)+import GHC.Word+import Data.Text.Internal.Encoding.Utf8 (utf8LengthByLeader)+#endif++import Foreign.C.Types (CSize(..))+import System.Posix.Types (CSsize(..))++#if defined(PURE_HASKELL)++measure_off :: ByteArray# -> CSize -> CSize -> CSize -> CSsize+measure_off ba off len cnt = go 0 0+  where+    go !cc !i+      -- return the number of bytes for the first cnt codepoints,+      | cc == cnt = fromIntegral i+      -- return negated number of codepoints if there are fewer than cnt+      | i >= len  = negate (fromIntegral cc)+      | otherwise =+          let !(I# o) = fromIntegral (off+i)+              !b = indexWord8Array# ba o+          in go (cc+1) (i + fromIntegral (utf8LengthByLeader (W8# b)))++#else++-- | 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" measure_off+    :: ByteArray# -> CSize -> CSize -> CSize -> CSsize++#endif
+ src/Data/Text/Internal/Reverse.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+#if defined(PURE_HASKELL)+{-# LANGUAGE BangPatterns #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}++-- | Implements 'reverse', using efficient C routines by default.+module Data.Text.Internal.Reverse (reverse, reverseNonEmpty) where++#if !defined(PURE_HASKELL)+import GHC.Exts as Exts+import Control.Monad.ST.Unsafe (unsafeIOToST)+import Foreign.C.Types (CSize(..))+#else+import Control.Monad.ST (ST)+import Data.Text.Internal.Encoding.Utf8 (utf8LengthByLeader)+#endif+#if defined(ASSERTS)+import GHC.Stack (HasCallStack)+#endif+import Prelude hiding (reverse)+import Data.Text.Internal (Text(..), empty)+import Control.Monad.ST (runST)+import qualified Data.Text.Array as A++-- | /O(n)/ Reverse the characters of a string.+--+-- Example:+--+-- $setup+-- >>> T.reverse "desrever"+-- "reversed"+reverse ::+#if defined(ASSERTS)+  HasCallStack =>+#endif+  Text -> Text+reverse (Text _ _ 0) = empty+reverse t            = reverseNonEmpty t+{-# INLINE reverse #-}++-- | /O(n)/ Reverse the characters of a string.+-- Assume that the @Text@ is non-empty. The returned @Text@ is guaranteed to be non-empty.+reverseNonEmpty ::+  Text -> Text+#if defined(PURE_HASKELL)+reverseNonEmpty (Text src off len) = runST $ do+    dest <- A.new len+    _ <- reversePoints src off dest len+    result <- A.unsafeFreeze dest+    pure $ Text result 0 len++-- Step 0:+--+-- Input:  R E D R U M+--         ^+--         x+-- Output: _ _ _ _ _ _+--                     ^+--                     y+--+-- Step 1:+--+-- Input:  R E D R U M+--           ^+--           x+--+-- Output: _ _ _ _ _ R+--                   ^+--                   y+reversePoints+    :: A.Array -- ^ Input array+    -> Int -- ^ Input index+    -> A.MArray s -- ^ Output array+    -> Int -- ^ Output index+    -> ST s ()+reversePoints src xx dest yy = go xx yy where+    go !_ y | y <= 0 = pure ()+    go x y =+        let pLen = utf8LengthByLeader (A.unsafeIndex src x)+            -- The next y is also the start of the current point in the output+            yNext = y - pLen+        in do+            A.copyI pLen dest yNext src x+            go (x + pLen) yNext+#else+reverseNonEmpty (Text (A.ByteArray ba) off len) = runST $ do+    marr@(A.MutableByteArray mba) <- A.new len+    unsafeIOToST $ c_reverse mba ba (fromIntegral off) (fromIntegral len)+    brr <- A.unsafeFreeze marr+    return $ Text brr 0 len+#endif+{-# INLINE reverseNonEmpty #-}++#if !defined(PURE_HASKELL)+-- | The input buffer (src :: ByteArray#, off :: CSize, len :: CSize)+-- must specify a valid UTF-8 sequence, this condition is not checked.+foreign import ccall unsafe "_hs_text_reverse" c_reverse+    :: Exts.MutableByteArray# s -> ByteArray# -> CSize -> CSize -> IO ()+#endif++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import qualified Data.Text.Internal.Reverse as T
src/Data/Text/Internal/Search.hs view
@@ -37,9 +37,7 @@ import Data.Word (Word64, Word8) import Data.Text.Internal (Text(..)) import Data.Bits ((.|.), (.&.), unsafeShiftL)-import Foreign.C.Types-import GHC.Exts (ByteArray#)-import System.Posix.Types (CSsize(..))+import Data.Text.Internal.ArrayUtils (memchr)  data T = {-# UNPACK #-} !Word64 :* {-# UNPACK #-} !Int @@ -87,9 +85,9 @@       | mask .&. swizzle (A.unsafeIndex harr i) == 0       = loop (i + nlen + 1)       | otherwise-      = case memchr harr# (intToCSize i) (intToCSize (hlen + hoff - i)) z of+      = case memchr harr# i (hlen + hoff - i) z of         -1 -> []-        x  -> loop (i + cSsizeToInt x + 1)+        x  -> loop (i + x + 1) {-# INLINE indices' #-}  scanOne :: Word8 -> Text -> [Int]@@ -103,12 +101,3 @@  word8ToInt :: Word8 -> Int word8ToInt = fromIntegral--intToCSize :: Int -> CSize-intToCSize = fromIntegral--cSsizeToInt :: CSsize -> Int-cSsizeToInt = fromIntegral--foreign import ccall unsafe "_hs_text_memchr" memchr-    :: ByteArray# -> CSize -> CSize -> Word8 -> CSsize
+ src/Data/Text/Internal/Transformation.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE BangPatterns, CPP, MagicHash #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PartialTypeSignatures #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}++-- |+-- Module      : Data.Text.Internal.Transformation+-- Copyright   : (c) 2008, 2009 Tom Harper,+--               (c) 2009, 2010 Bryan O'Sullivan,+--               (c) 2009 Duncan Coutts+--+-- License     : BSD-style+-- Maintainer  : bos@serpentine.com+-- Stability   : experimental+-- Portability : GHC+--+-- This module holds functions shared between the strict and lazy implementations of @Text@ transformations.++module Data.Text.Internal.Transformation+  ( mapNonEmpty+  , toCaseFoldNonEmpty+  , toLowerNonEmpty+  , toUpperNonEmpty+  , filter_+  ) where++import Prelude (Char, Bool(..), Int,+                Ord(..),+                Monad(..), pure,+                (+), (-), ($),+                not, return, otherwise)+import Data.Bits ((.&.), shiftR, shiftL)+import Control.Monad.ST (ST, runST)+import qualified Data.Text.Array as A+import Data.Text.Internal.Encoding.Utf8 (utf8LengthByLeader, chr2, chr3, chr4)+import Data.Text.Internal.Fusion.CaseMapping (foldMapping, lowerMapping, upperMapping)+import Data.Text.Internal (Text(..), safe)+import Data.Text.Internal.Unsafe.Char (unsafeWrite, unsafeChr8)+import qualified Prelude as P+import Data.Text.Unsafe (Iter(..), iterArray)+import Data.Word (Word8)+import qualified GHC.Exts as Exts+import GHC.Int (Int64(..))++-- | /O(n)/ 'map' @f@ @t@ is the 'Text' obtained by applying @f@ to+-- each element of @t@.+-- Assume that the @Text@ is non-empty. The returned @Text@ is guaranteed to be non-empty.+mapNonEmpty :: (Char -> Char) -> Text -> Text+mapNonEmpty f = go+  where+    go (Text src o l) = runST $ do+      marr <- A.new (l + 4)+      outer marr (l + 4) o 0+      where+        outer :: forall s. A.MArray s -> Int -> Int -> Int -> ST s Text+        outer !dst !dstLen = inner+          where+            inner !srcOff !dstOff+              | srcOff >= l + o = do+                A.shrinkM dst dstOff+                arr <- A.unsafeFreeze dst+                return (Text arr 0 dstOff)+              | dstOff + 4 > dstLen = do+                let !dstLen' = dstLen + (l + o) - srcOff + 4+                dst' <- A.resizeM dst dstLen'+                outer dst' dstLen' srcOff dstOff+              | otherwise = do+                let !(Iter c d) = iterArray src srcOff+                d' <- unsafeWrite dst dstOff (safe (f c))+                inner (srcOff + d) (dstOff + d')+{-# INLINE mapNonEmpty #-}++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.+-- Assume that the @Text@ is non-empty. The returned @Text@ is guaranteed to be non-empty.+toCaseFoldNonEmpty :: Text -> Text+toCaseFoldNonEmpty  = \xs -> caseConvert (\w -> if w - 65 <= 25 then w + 32 else w) foldMapping xs+{-# INLINE toCaseFoldNonEmpty #-}++-- | /O(n)/ Convert a string to lower case, using simple case+-- conversion.+-- Assume that the @Text@ is non-empty. The returned @Text@ is guaranteed to be non-empty.+toLowerNonEmpty :: Text -> Text+toLowerNonEmpty = \xs -> caseConvert (\w -> if w - 65 <= 25 then w + 32 else w) lowerMapping xs+{-# INLINE toLowerNonEmpty #-}++-- | /O(n)/ Convert a string to upper case, using simple case+-- conversion.+-- Assume that the @Text@ is non-empty. The returned @Text@ is guaranteed to be non-empty.+toUpperNonEmpty :: Text -> Text+toUpperNonEmpty = \xs -> caseConvert (\w -> if w - 97 <= 25 then w - 32 else w) upperMapping xs+{-# INLINE toUpperNonEmpty #-}++-- | /O(n)/ 'filter_', applied to a continuation, a predicate and a @Text@,+-- calls the continuation with the @Text@ containing only the characters satisfying the predicate.+filter_ :: forall a. (A.Array -> Int -> Int -> a) -> (Char -> Bool) -> Text -> a+filter_ mkText p = go+  where+    go (Text src o l) = runST $ do+      -- It's tempting to allocate l elements at once and avoid resizing.+      -- However, this can be unacceptable in scenarios where a huge array+      -- is filtered with a rare predicate, resulting in a much shorter buffer.+      let !dstLen = min l 64+      dst <- A.new dstLen+      outer dst dstLen o 0+      where+        outer :: forall s. A.MArray s -> Int -> Int -> Int -> ST s a+        outer !dst !dstLen = inner+          where+            inner !srcOff !dstOff+              | srcOff >= o + l = do+                A.shrinkM dst dstOff+                arr <- A.unsafeFreeze dst+                return $ mkText arr 0 dstOff+              | dstOff + 4 > dstLen = do+                -- Double size of the buffer, unless it becomes longer than+                -- source string. Ensure to extend it by least 4 bytes.+                let !dstLen' = dstLen + max 4 (min (l + o - srcOff) dstLen)+                dst' <- A.resizeM dst dstLen'+                outer dst' dstLen' srcOff dstOff+              -- In case of success, filter writes exactly the same character+              -- it just read (this is not a case for map, for example).+              -- We leverage this fact below: 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+                    let !c = unsafeChr8 m0+                    if not (p c) then inner (srcOff + 1) dstOff else do+                      A.unsafeWrite dst dstOff m0+                      inner (srcOff + 1) (dstOff + 1)+                  2 -> do+                    let !c = chr2 m0 m1+                    if not (p c) then inner (srcOff + 2) dstOff else do+                      A.unsafeWrite dst dstOff m0+                      A.unsafeWrite dst (dstOff + 1) m1+                      inner (srcOff + 2) (dstOff + 2)+                  3 -> do+                    let !c = chr3 m0 m1 m2+                    if not (p c) then inner (srcOff + 3) dstOff else do+                      A.unsafeWrite dst dstOff m0+                      A.unsafeWrite dst (dstOff + 1) m1+                      A.unsafeWrite dst (dstOff + 2) m2+                      inner (srcOff + 3) (dstOff + 3)+                  _ -> do+                    let !c = chr4 m0 m1 m2 m3+                    if not (p c) then inner (srcOff + 4) dstOff else do+                      A.unsafeWrite dst dstOff m0+                      A.unsafeWrite dst (dstOff + 1) m1+                      A.unsafeWrite dst (dstOff + 2) m2+                      A.unsafeWrite dst (dstOff + 3) m3+                      inner (srcOff + 4) (dstOff + 4)+{-# INLINE filter_ #-}
src/Data/Text/Internal/Validate.hs view
@@ -37,14 +37,8 @@ import Data.Text.Internal.Unsafe (unsafeWithForeignPtr) import Data.Text.Internal.Validate.Simd (c_is_valid_utf8_bytearray_safe,c_is_valid_utf8_bytearray_unsafe,c_is_valid_utf8_ptr_unsafe) #else-import GHC.Exts (ByteArray#)-import Data.Text.Internal.Encoding.Utf8 (CodePoint(..),DecoderResult(..),utf8DecodeStart,utf8DecodeContinue)-import GHC.Exts (Int(I#),indexWord8Array#)-import GHC.Word (Word8(W8#)) import qualified Data.ByteString as B-#if !MIN_VERSION_bytestring(0,11,2)-import qualified Data.ByteString.Unsafe as B-#endif+import qualified Data.Text.Internal.Validate.Native as N #endif  -- | Is the ByteString a valid UTF-8 byte sequence?@@ -53,24 +47,13 @@ isValidUtf8ByteString bs = withBS bs $ \fp len -> unsafeDupablePerformIO $   unsafeWithForeignPtr fp $ \ptr -> (/= 0) <$> c_is_valid_utf8_ptr_unsafe ptr (fromIntegral len) #else-#if MIN_VERSION_bytestring(0,11,2)+-- B.isValidUtf8 is buggy before bytestring-0.11.5.3 / bytestring-0.12.1.0.+-- MIN_VERSION_bytestring does not allow us to differentiate+-- between 0.11.5.2 and 0.11.5.3 so no choice except demanding 0.12.1+.+#if MIN_VERSION_bytestring(0,12,1) isValidUtf8ByteString = B.isValidUtf8 #else-isValidUtf8ByteString bs = start 0-  where-    start ix-      | ix >= B.length bs = True-      | otherwise = case utf8DecodeStart (B.unsafeIndex bs ix) of-        Accept{} -> start (ix + 1)-        Reject{} -> False-        Incomplete st _ -> step (ix + 1) st-    step ix st-      | ix >= B.length bs = False-      -- We do not use decoded code point, so passing a dummy value to save an argument.-      | otherwise = case utf8DecodeContinue (B.unsafeIndex bs ix) st (CodePoint 0) of-        Accept{} -> start (ix + 1)-        Reject{} -> False-        Incomplete st' _ -> step (ix + 1) st'+isValidUtf8ByteString = N.isValidUtf8ByteStringHaskell #endif #endif @@ -103,7 +86,7 @@ isValidUtf8ByteArrayUnpinned (ByteArray bs) !off !len =   unsafeDupablePerformIO $ (/= 0) <$> c_is_valid_utf8_bytearray_unsafe bs (fromIntegral off) (fromIntegral len) #else-isValidUtf8ByteArrayUnpinned (ByteArray bs) = isValidUtf8ByteArrayHaskell# bs+isValidUtf8ByteArrayUnpinned = N.isValidUtf8ByteArrayHaskell #endif  -- | This uses the @safe@ FFI. GC may run concurrently with @safe@@@ -120,30 +103,5 @@ isValidUtf8ByteArrayPinned (ByteArray bs) !off !len =   unsafeDupablePerformIO $ (/= 0) <$> c_is_valid_utf8_bytearray_safe bs (fromIntegral off) (fromIntegral len) #else-isValidUtf8ByteArrayPinned (ByteArray bs) = isValidUtf8ByteArrayHaskell# bs-#endif--#ifndef SIMDUTF-isValidUtf8ByteArrayHaskell# ::-     ByteArray# -- ^ Bytes-  -> Int -- ^ Offset-  -> Int -- ^ Length-  -> Bool-isValidUtf8ByteArrayHaskell# b !off !len = start off-  where-    indexWord8 :: ByteArray# -> Int -> Word8-    indexWord8 !x (I# i) = W8# (indexWord8Array# x i)-    start ix-      | ix >= len = True-      | otherwise = case utf8DecodeStart (indexWord8 b ix) of-        Accept{} -> start (ix + 1)-        Reject{} -> False-        Incomplete st _ -> step (ix + 1) st-    step ix st-      | ix >= len = False-      -- We do not use decoded code point, so passing a dummy value to save an argument.-      | otherwise = case utf8DecodeContinue (indexWord8 b ix) st (CodePoint 0) of-        Accept{} -> start (ix + 1)-        Reject{} -> False-        Incomplete st' _ -> step (ix + 1) st'+isValidUtf8ByteArrayPinned = N.isValidUtf8ByteArrayHaskell #endif
+ src/Data/Text/Internal/Validate/Native.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}++-- | Native implementation of 'Data.Text.Internal.Validate'.+module Data.Text.Internal.Validate.Native+  ( isValidUtf8ByteStringHaskell+  , isValidUtf8ByteArrayHaskell+  ) where++import Data.Array.Byte (ByteArray(ByteArray))+import Data.ByteString (ByteString)+import GHC.Exts (ByteArray#,Int(I#),indexWord8Array#)+import GHC.Word (Word8(W8#))+import Data.Text.Internal.Encoding.Utf8 (CodePoint(..),DecoderResult(..),utf8DecodeStart,utf8DecodeContinue)+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B++-- | Native implementation of 'Data.Text.Internal.Validate.isValidUtf8ByteString'.+isValidUtf8ByteStringHaskell :: ByteString -> Bool+isValidUtf8ByteStringHaskell 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'++-- | Native implementation of+-- 'Data.Text.Internal.Validate.isValidUtf8ByteArrayUnpinned'+-- and 'Data.Text.Internal.Validate.isValidUtf8ByteArrayPinned'.+isValidUtf8ByteArrayHaskell ::+     ByteArray -- ^ Bytes+  -> Int -- ^ Offset+  -> Int -- ^ Length+  -> Bool+isValidUtf8ByteArrayHaskell (ByteArray b) !off !len = start off+  where+    indexWord8 :: ByteArray# -> Int -> Word8+    indexWord8 !x (I# i) = W8# (indexWord8Array# x i)+    start ix+      | ix >= off + len = True+      | otherwise = case utf8DecodeStart (indexWord8 b ix) of+        Accept{} -> start (ix + 1)+        Reject{} -> False+        Incomplete st _ -> step (ix + 1) st+    step ix st+      | ix >= off + len = False+      -- We do not use decoded code point, so passing a dummy value to save an argument.+      | otherwise = case utf8DecodeContinue (indexWord8 b ix) st (CodePoint 0) of+        Accept{} -> start (ix + 1)+        Reject{} -> False+        Incomplete st' _ -> step (ix + 1) st'
src/Data/Text/Lazy.hs view
@@ -46,6 +46,7 @@      -- * Types       Text+    , LazyText      -- * Creation and elimination     , pack@@ -230,8 +231,10 @@ import Data.Text.Internal.Fusion.Types (PairS(..)) import Data.Text.Internal.Lazy.Fusion (stream, unstream) import Data.Text.Internal.Lazy (Text(..), chunk, empty, foldlChunks,-                                foldrChunks, smallChunkSize, defaultChunkSize, equal)+                                foldrChunks, smallChunkSize, defaultChunkSize, equal, LazyText) import Data.Text.Internal (firstf, safe, text)+import Data.Text.Internal.Reverse (reverseNonEmpty)+import Data.Text.Internal.Transformation (mapNonEmpty, toCaseFoldNonEmpty, toLowerNonEmpty, toUpperNonEmpty, filter_) import Data.Text.Lazy.Encoding (decodeUtf8', encodeUtf8) import Data.Text.Internal.Lazy.Search (indices) import qualified GHC.CString as GHC@@ -441,12 +444,12 @@ toChunks cs = foldrChunks (:) [] cs  -- | /O(n)/ Convert a lazy 'Text' into a strict 'T.Text'.-toStrict :: Text -> T.Text+toStrict :: LazyText -> T.StrictText toStrict t = T.concat (toChunks t) {-# INLINE [1] toStrict #-}  -- | /O(c)/ Convert a strict 'T.Text' into a lazy 'Text'.-fromStrict :: T.Text -> Text+fromStrict :: T.StrictText -> LazyText fromStrict t = chunk t Empty {-# INLINE [1] fromStrict #-} @@ -577,7 +580,7 @@ -- each element of @t@. Performs replacement on -- invalid scalar values. map :: (Char -> Char) -> Text -> Text-map f = foldrChunks (Chunk . T.map f) Empty+map f = foldrChunks (Chunk . mapNonEmpty f) Empty {-# INLINE [1] map #-}  {-# RULES@@ -663,7 +666,7 @@   Text -> Text reverse = rev Empty   where rev a Empty        = a-        rev a (Chunk t ts) = rev (Chunk (T.reverse t) a) ts+        rev a (Chunk t ts) = rev (Chunk (reverseNonEmpty t) a) ts  -- | /O(m+n)/ Replace every non-overlapping occurrence of @needle@ in -- @haystack@ with @replacement@.@@ -728,7 +731,7 @@ -- case folded to the Greek small letter letter mu (U+03BC) instead of -- itself. toCaseFold :: Text -> Text-toCaseFold = foldrChunks (\chnk acc -> Chunk (T.toCaseFold chnk) acc) Empty+toCaseFold = foldrChunks (\chnk acc -> Chunk (toCaseFoldNonEmpty chnk) acc) Empty {-# INLINE toCaseFold #-}  -- | /O(n)/ Convert a string to lower case, using simple case@@ -739,7 +742,7 @@ -- to the sequence Latin small letter i (U+0069) followed by combining -- dot above (U+0307). toLower :: Text -> Text-toLower = foldrChunks (\chnk acc -> Chunk (T.toLower chnk) acc) Empty+toLower = foldrChunks (\chnk acc -> Chunk (toLowerNonEmpty chnk) acc) Empty {-# INLINE toLower #-}  -- | /O(n)/ Convert a string to upper case, using simple case@@ -749,7 +752,7 @@ -- instance, the German eszett (U+00DF) maps to the two-letter -- sequence SS. toUpper :: Text -> Text-toUpper = foldrChunks (\chnk acc -> Chunk (T.toUpper chnk) acc) Empty+toUpper = foldrChunks (\chnk acc -> Chunk (toUpperNonEmpty chnk) acc) Empty {-# INLINE toUpper #-}  @@ -1682,12 +1685,12 @@ -- returns a 'Text' containing those characters that satisfy the -- predicate. filter :: (Char -> Bool) -> Text -> Text-filter p = foldrChunks (chunk . T.filter p) Empty+filter p = foldrChunks (chunk . filter_ T.Text p) Empty {-# INLINE [1] filter #-}  {-# RULES "TEXT filter/filter -> filter" forall p q t.-    filter p (filter q t) = filter (\c -> p c && q c) t+    filter p (filter q t) = filter (\c -> q c && p c) t #-}  -- | /O(n)/ The 'find' function takes a predicate and a 'Text', and
src/Data/Text/Show.hs view
@@ -24,7 +24,7 @@     ) where  import Control.Monad.ST (ST, runST)-import Data.Text.Internal (Text(..), empty_, safe, pack)+import Data.Text.Internal (Text(..), empty, safe, pack) import Data.Text.Internal.Encoding.Utf8 (utf8Length) import Data.Text.Internal.Fusion (stream) import Data.Text.Internal.Unsafe.Char (unsafeWrite)@@ -123,7 +123,7 @@     pack (GHC.unpackCStringUtf8# a) = unpackCString# a #-}  {-# RULES "TEXT empty literal"-    pack [] = empty_ #-}+    pack [] = empty #-}  {-# RULES "TEXT singleton literal" forall a.     pack [a] = singleton a #-}
tests/Tests.hs view
@@ -9,6 +9,7 @@ import qualified Tests.Lift as Lift import qualified Tests.Properties as Properties import qualified Tests.Regressions as Regressions+import qualified Tests.ShareEmpty as ShareEmpty import qualified Tests.RebindableSyntaxTest as RST  main :: IO ()@@ -16,5 +17,6 @@   [ Lift.tests   , Properties.tests   , Regressions.tests+  , ShareEmpty.tests   , RST.tests   ]
tests/Tests/Properties.hs view
@@ -16,6 +16,7 @@ import Tests.Properties.Read (testRead) import Tests.Properties.Text (testText) import Tests.Properties.Transcoding (testTranscoding)+import Tests.Properties.Validate (testValidate)  tests :: TestTree tests =@@ -28,5 +29,6 @@     testSubstrings,     testBuilder,     testLowLevel,-    testRead+    testRead,+    testValidate   ]
+ tests/Tests/Properties/Validate.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP #-}+module Tests.Properties.Validate (testValidate) where++import Data.Array.Byte (ByteArray)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.ByteString.Short (toShort)+import Data.Either (isRight)+import Data.Text.Encoding (decodeUtf8', encodeUtf8)+import Data.Text.Internal.Validate (isValidUtf8ByteString, isValidUtf8ByteArray)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck ((===), Gen, Property,+  testProperty, arbitrary, forAllShrink, oneof, shrink)+import Tests.QuickCheckUtils ()+#if MIN_VERSION_bytestring(0,12,0)+import Data.ByteString.Short (unShortByteString)+#else+#if MIN_VERSION_bytestring(0,11,1)+import Data.ByteString.Short (ShortByteString(SBS))+#else+import Data.ByteString.Short.Internal (ShortByteString(SBS))+#endif+import Data.Array.Byte (ByteArray(ByteArray))++unShortByteString :: ShortByteString -> ByteArray+unShortByteString (SBS ba) = ByteArray ba+#endif++testValidate :: TestTree+testValidate = testGroup "validate"+  [ testProperty "bytestring" $ forAllShrink genByteString shrink $ \bs ->+      isValidUtf8ByteString bs === isRight (decodeUtf8' bs)+  , testProperty "bytearray" $ forAllByteArray $ \ba off len bs ->+      isValidUtf8ByteArray ba off len === isRight (decodeUtf8' bs)+  ]++genByteString :: Gen ByteString+genByteString = oneof+  [ arbitrary+  , encodeUtf8 <$> arbitrary+  ]++-- | We want to test 'isValidUtf8ByteArray' with various offsets, so we insert a random+-- prefix and remember its length.+forAllByteArray :: (ByteArray -> Int -> Int -> ByteString -> Property) -> Property+forAllByteArray prop =+  forAllShrink genByteString shrink $ \mainSlice ->+  forAllShrink arbitrary shrink $ \prefix ->+  let bs2ba = unShortByteString . toShort in+  prop (bs2ba (prefix `B.append` mainSlice)) (B.length prefix) (B.length mainSlice) mainSlice
tests/Tests/Regressions.hs view
@@ -176,6 +176,13 @@     (T.pack (chr 33 : replicate 31 (chr 0) ++ [chr 65533, chr 0]))     (decode (B.pack (33 : replicate 31 0 ++ [128, 0]))) +-- See Github #559+-- filter/filter fusion rules should apply predicates in the right order.+t559 :: IO ()+t559 = do+  T.filter undefined (T.filter (const False) "a") @?= ""+  LT.filter undefined (LT.filter (const False) "a") @?= ""+ tests :: F.TestTree tests = F.testGroup "Regressions"     [ F.testCase "hGetContents_crash" hGetContents_crash@@ -193,4 +200,5 @@     , F.testCase "t525" t525     , F.testCase "t528" t528     , F.testCase "t529" t529+    , F.testCase "t559" t559     ]
+ tests/Tests/ShareEmpty.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BangPatterns #-}++module Tests.ShareEmpty+  ( tests+  ) where++import Control.Exception (evaluate)+import Data.Text+import Language.Haskell.TH.Syntax (lift)+import Test.Tasty.HUnit (testCase, assertFailure, assertEqual)+import Test.Tasty (TestTree, testGroup)+import GHC.Exts+import GHC.Stack+import qualified Data.List as L+import qualified Data.Text as T+++-- | assert that a text value is represented by the same pointer+-- as the 'empty' value.+assertPtrEqEmpty :: HasCallStack => Text -> IO ()+assertPtrEqEmpty t = do +    t' <- evaluate t+    empty' <- evaluate empty+    assertEqual "" empty' t'+    case reallyUnsafePtrEquality# empty' t' of+      1# -> pure ()+      _ -> assertFailure "Pointers are not equal"+{-# NOINLINE assertPtrEqEmpty #-}++tests :: TestTree+tests = testGroup "empty Text values are shared"+  [ testCase "empty = empty" $ assertPtrEqEmpty T.empty+  , testCase "pack \"\" = empty" $ assertPtrEqEmpty $ T.pack ""+  , testCase "fromString \"\" = empty" $ assertPtrEqEmpty $ fromString ""+  , testCase "$(lift \"\") = empty" $ assertPtrEqEmpty $ $(lift (pack ""))+  , testCase "tail of a singleton = empty" $ assertPtrEqEmpty $ T.tail "a"+  , testCase "init of a singleton = empty" $ assertPtrEqEmpty $ T.init "b"+  , testCase "map _ empty = empty" $ assertPtrEqEmpty $ T.map id empty+  , testCase "intercalate _ [] = empty" $ assertPtrEqEmpty $ T.intercalate ", " []+  , testCase "intersperse _ empty = empty" $ assertPtrEqEmpty $ T.intersperse ',' ""+  , testCase "reverse empty = empty" $ assertPtrEqEmpty $+      T.reverse empty+  , testCase "replace _ _ empty = empty" $ assertPtrEqEmpty $+      T.replace "needle" "replacement" empty+  , testCase "toCaseFold empty = empty" $ assertPtrEqEmpty $ T.toCaseFold ""+  , testCase "toLower empty = empty" $ assertPtrEqEmpty $ T.toLower ""+  , testCase "toUpper empty = empty" $ assertPtrEqEmpty $ T.toUpper ""+  , testCase "toTitle empty = empty" $ assertPtrEqEmpty $ T.toTitle ""+  , testCase "justifyLeft 0 _ empty = empty" $ assertPtrEqEmpty $+      justifyLeft 0 ' ' empty+  , testCase "justifyRight 0 _ empty = empty" $ assertPtrEqEmpty $+      justifyRight 0 ' ' empty+  , testCase "center 0 _ empty = empty" $ assertPtrEqEmpty $+      T.center 0 ' ' empty+  , testCase "transpose [empty] = [empty]" $ mapM_ assertPtrEqEmpty $+      T.transpose [empty]+  , testCase "concat [] = empty" $ assertPtrEqEmpty $ T.concat []+  , testCase "concat [empty] = empty" $ assertPtrEqEmpty $ T.concat [empty]+  , testCase "replicate 0 _ = empty" $ assertPtrEqEmpty $ T.replicate 0 "x"+  , testCase "replicate _ empty = empty" $ assertPtrEqEmpty $ T.replicate 10 empty+  , testCase "unfoldr (const Nothing) _ = empty" $ assertPtrEqEmpty $+      T.unfoldr (const Nothing) ()+  , testCase "take 0 _ = empty" $ assertPtrEqEmpty $+      T.take 0 "xyz"+  , testCase "takeEnd 0 _ = empty" $ assertPtrEqEmpty $+      T.takeEnd 0 "xyz"+  , testCase "takeWhile (const False) _ = empty" $ assertPtrEqEmpty $+      T.takeWhile (const False) "xyz"+  , testCase "takeWhileEnd (const False) _ = empty" $ assertPtrEqEmpty $+      T.takeWhileEnd (const False) "xyz"+  , testCase "drop n x = empty where n > len x" $ assertPtrEqEmpty $+      T.drop 5 "xyz"+  , testCase "dropEnd n x = empty where n > len x" $ assertPtrEqEmpty $+      T.dropEnd 5 "xyz"+  , testCase "dropWhile (const True) x = empty" $ assertPtrEqEmpty $+      T.dropWhile (const True) "xyz"+  , testCase "dropWhileEnd (const True) x = empty" $ assertPtrEqEmpty $+      dropWhileEnd (const True) "xyz"+  , testCase "dropAround _ empty = empty" $ assertPtrEqEmpty $+      dropAround (const True) empty+  , testCase "stripStart empty = empty" $ assertPtrEqEmpty $ T.stripStart empty+  , testCase "stripEnd empty = empty" $ assertPtrEqEmpty $ T.stripEnd empty+  , testCase "strip empty = empty" $ assertPtrEqEmpty $ T.strip empty+  , testCase "fst (splitAt 0 _) = empty" $ assertPtrEqEmpty $ fst $ T.splitAt 0 "123"+  , testCase "snd (splitAt n x) = empty where n > len x" $ assertPtrEqEmpty $+      snd $ T.splitAt 5 "123"+  , testCase "fst (span (const False) _) = empty" $ assertPtrEqEmpty $+      fst $ T.span (const False) "123"+  , testCase "snd (span (const True) _) = empty" $ assertPtrEqEmpty $+      snd $ T.span (const True) "123"+  , testCase "fst (break (const False) _) = empty" $ assertPtrEqEmpty $+      fst $ T.span (const False) "123"+  , testCase "snd (break (const True) _) = empty" $ assertPtrEqEmpty $+      snd $ T.span (const True) "123"+  , testCase "fst (spanM (const $ pure False) _) = empty" $+      assertPtrEqEmpty . fst =<< T.spanM (const $ pure False) "123"+  , testCase "snd (spanM (const $ pure True) _) = empty" $+      assertPtrEqEmpty . snd =<< T.spanM (const $ pure True) "123"+  , testCase "fst (spanEndM (const $ pure True) _) = empty" $+      assertPtrEqEmpty . fst =<< T.spanEndM (const $ pure True) "123"+  , testCase "snd (spanEndM (const $ pure False) _) = empty" $+      assertPtrEqEmpty . snd =<< T.spanEndM (const $ pure False) "123"+  , testCase "groupBy _ empty = [empty]" $ mapM_ assertPtrEqEmpty $ T.groupBy (==) empty+  , testCase "inits empty = [empty]" $ mapM_ assertPtrEqEmpty $ T.inits empty+  , testCase "inits _ = [empty, ...]" $ assertPtrEqEmpty $ L.head $ T.inits "123"+  , testCase "tails empty = [empty]" $ mapM_ assertPtrEqEmpty $ T.tails empty+  , testCase "tails _ = [..., empty]" $ assertPtrEqEmpty $ L.last $ T.tails "123"+  , testCase "tails _ = [..., empty]" $ assertPtrEqEmpty $ L.last $ T.tails "123"+  , testCase "split _ empty = [empty]" $ mapM_ assertPtrEqEmpty $ T.split (== 'a') ""+  , testCase "filter (const False) _ = empty" $ assertPtrEqEmpty $ T.filter (const False) "1234"+  , testCase "zipWith const empty empty = empty" $ assertPtrEqEmpty $ T.zipWith const "" ""+  , testCase "unlines [] = empty" $ assertPtrEqEmpty $ T.unlines []+  , testCase "unwords [] = empty" $ assertPtrEqEmpty $ T.unwords []+  , testCase "stripPrefix empty empty = Just empty" $ mapM_ assertPtrEqEmpty $+      T.stripPrefix empty empty+  , testCase "stripSuffix empty empty = Just empty" $ mapM_ assertPtrEqEmpty $+      T.stripSuffix empty empty+  , testCase "commonPrefixes \"xyz\" \"123\" = Just (_, empty, _)" $+      mapM_ (assertPtrEqEmpty . (\(_, x, _) -> x)) $ T.commonPrefixes "xyz" "123"+  , testCase "commonPrefixes \"xyz\" \"xyz\" = Just (_, _, empty)" $+      mapM_ (assertPtrEqEmpty . (\(_, _, x) -> x)) $ T.commonPrefixes "xyz" "xyz"+  , testCase "copy empty = empty" $ assertPtrEqEmpty $ T.copy ""+  ]
text.cabal view
@@ -1,6 +1,6 @@ cabal-version:  2.2 name:           text-version:        2.1+version:        2.1.1  homepage:       https://github.com/haskell/text bug-reports:    https://github.com/haskell/text/issues@@ -79,14 +79,32 @@   default: True   manual: True +flag pure-haskell+  description: Don't use text's standard C routines+    NB: This feature is not fully implemented. Several C routines are still in+    use.++    When this flag is true, text will use pure Haskell variants of the+    routines. This is not recommended except for use with GHC's JavaScript+    backend.++    This flag also disables simdutf.++  default: False+  manual: True+ library-  c-sources:    cbits/is_ascii.c+  if arch(javascript) || flag(pure-haskell)+    cpp-options: -DPURE_HASKELL+  else+    c-sources:  cbits/is_ascii.c                 cbits/measure_off.c                 cbits/reverse.c                 cbits/utils.c+   hs-source-dirs: src -  if flag(simdutf)+  if flag(simdutf) && !(arch(javascript) || flag(pure-haskell))     exposed-modules: Data.Text.Internal.Validate.Simd     include-dirs: simdutf     cxx-sources: simdutf/simdutf.cpp@@ -143,6 +161,7 @@     Data.Text.IO     Data.Text.IO.Utf8     Data.Text.Internal+    Data.Text.Internal.ArrayUtils     Data.Text.Internal.Builder     Data.Text.Internal.Builder.Functions     Data.Text.Internal.Builder.Int.Digits@@ -172,6 +191,7 @@     Data.Text.Internal.Unsafe     Data.Text.Internal.Unsafe.Char     Data.Text.Internal.Validate+    Data.Text.Internal.Validate.Native     Data.Text.Lazy     Data.Text.Lazy.Builder     Data.Text.Lazy.Builder.Int@@ -185,6 +205,10 @@    other-modules:     Data.Text.Show+    Data.Text.Internal.Measure+    Data.Text.Internal.Reverse+    Data.Text.Internal.Transformation+    Data.Text.Internal.IsAscii    build-depends:     array            >= 0.3 && < 0.6,@@ -235,7 +259,7 @@ test-suite tests   type:           exitcode-stdio-1.0   ghc-options:-    -Wall -threaded -rtsopts+    -Wall -threaded -rtsopts -with-rtsopts=-N    hs-source-dirs: tests   main-is:        Tests.hs@@ -251,10 +275,12 @@     Tests.Properties.Substrings     Tests.Properties.Text     Tests.Properties.Transcoding+    Tests.Properties.Validate     Tests.QuickCheckUtils     Tests.RebindableSyntaxTest     Tests.Regressions     Tests.SlowFunctions+    Tests.ShareEmpty     Tests.Utils    build-depends:@@ -270,7 +296,8 @@     template-haskell,     transformers,     text-+  if impl(ghc < 9.4)+    build-depends: data-array-byte >= 0.1 && < 0.2   -- 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.2.1 && < 8.6 || >= 8.6.2 && < 9.2 || >= 9.2.2)