From a272e6459fa164057db28b6335f3f912f520c59d Mon Sep 17 00:00:00 2001 From: Bodigrim Date: Fri, 11 Jun 2021 18:40:17 +0100 Subject: [PATCH 1/2] Disable implicit fusion rules --- src/Data/Text.hs | 203 +++++----------------- src/Data/Text/Encoding.hs | 2 - src/Data/Text/Internal/Fusion/Common.hs | 7 +- src/Data/Text/Lazy.hs | 220 ++++-------------------- src/Data/Text/Lazy/Encoding.hs | 5 - src/Data/Text/Show.hs | 4 +- tests/Tests.hs | 9 - tests/Tests/Inspection/Lazy.hs | 181 ------------------- tests/Tests/Inspection/Strict.hs | 210 ---------------------- text.cabal | 10 -- 10 files changed, 81 insertions(+), 770 deletions(-) delete mode 100644 tests/Tests/Inspection/Lazy.hs delete mode 100644 tests/Tests/Inspection/Strict.hs diff --git a/src/Data/Text.hs b/src/Data/Text.hs index f97e2501..c95f66bf 100644 --- a/src/Data/Text.hs +++ b/src/Data/Text.hs @@ -43,9 +43,6 @@ module Data.Text -- * Definition of character -- $character_definition - -- * Fusion - -- $fusion - -- * Types Text @@ -311,31 +308,6 @@ import Text.Printf (PrintfArg, formatArg, formatString) -- measure. For details, see -- .) --- $fusion --- --- Most of the functions in this module are subject to /fusion/, --- meaning that a pipeline of such functions will usually allocate at --- most one 'Text' value. --- --- As an example, consider the following pipeline: --- --- > import Data.Text as T --- > import Data.Text.Encoding as E --- > import Data.ByteString (ByteString) --- > --- > countChars :: ByteString -> Int --- > countChars = T.length . T.toUpper . E.decodeUtf8 --- --- From the type signatures involved, this looks like it should --- allocate one 'Data.ByteString.ByteString' value, and two 'Text' --- values. However, when a module is compiled with optimisation --- enabled under GHC, the two intermediate 'Text' values will be --- optimised away, and the function will be compiled down to a single --- loop over the source 'Data.ByteString.ByteString'. --- --- Functions that can be fused by the compiler are documented with the --- phrase \"Subject to fusion\". - instance Eq Text where Text arrA offA lenA == Text arrB offB lenB | lenA == lenB = A.equal arrA offA arrB offB lenA @@ -439,8 +411,8 @@ compareText ta@(Text _arrA _offA lenA) tb@(Text _arrB _offB lenB) -- ----------------------------------------------------------------------------- -- * Conversion to/from 'Text' --- | /O(n)/ Convert a 'String' into a 'Text'. Subject to --- fusion. Performs replacement on invalid scalar values. +-- | /O(n)/ Convert a 'String' into a 'Text'. +-- Performs replacement on invalid scalar values. pack :: String -> Text pack = unstream . S.map safe . S.streamList {-# INLINE [1] pack #-} @@ -450,7 +422,7 @@ pack = unstream . S.map safe . S.streamList -- | /O(n)/ Adds a character to the front of a 'Text'. This function -- is more costly than its 'List' counterpart because it requires --- copying a new array. Subject to fusion. Performs replacement on +-- copying a new array. Performs replacement on -- invalid scalar values. cons :: Char -> Text -> Text cons c t = unstream (S.cons (safe c) (stream t)) @@ -459,14 +431,14 @@ cons c t = unstream (S.cons (safe c) (stream t)) infixr 5 `cons` -- | /O(n)/ Adds a character to the end of a 'Text'. This copies the --- entire array in the process, unless fused. Subject to fusion. +-- entire array in the process. -- Performs replacement on invalid scalar values. snoc :: Text -> Char -> Text snoc t c = unstream (S.snoc (stream t) (safe c)) {-# INLINE snoc #-} -- | /O(n)/ Appends one 'Text' to the other by copying both of them --- into a new 'Text'. Subject to fusion. +-- into a new 'Text'. append :: Text -> Text -> Text append a@(Text arr1 off1 len1) b@(Text arr2 off2 len2) | len1 == 0 = b @@ -483,21 +455,14 @@ append a@(Text arr1 off1 len1) b@(Text arr2 off2 len2) return arr {-# NOINLINE append #-} -{-# RULES -"TEXT append -> fused" [~1] forall t1 t2. - append t1 t2 = unstream (S.append (stream t1) (stream t2)) -"TEXT append -> unfused" [1] forall t1 t2. - unstream (S.append (stream t1) (stream t2)) = append t1 t2 - #-} - -- | /O(1)/ Returns the first character of a 'Text', which must be --- non-empty. Subject to fusion. +-- non-empty. head :: Text -> Char head t = S.head (stream t) {-# INLINE head #-} -- | /O(1)/ Returns the first character and rest of a 'Text', or --- 'Nothing' if empty. Subject to fusion. +-- 'Nothing' if empty. uncons :: Text -> Maybe (Char, Text) uncons t@(Text arr off len) | len <= 0 = Nothing @@ -510,7 +475,7 @@ second :: (b -> c) -> (a,b) -> (a,c) second f (a, b) = (a, f b) -- | /O(1)/ Returns the last character of a 'Text', which must be --- non-empty. Subject to fusion. +-- non-empty. last :: Text -> Char last (Text arr off len) | len <= 0 = emptyError "last" @@ -520,15 +485,8 @@ last (Text arr off len) n0 = A.unsafeIndex arr (off+len-2) {-# INLINE [1] last #-} -{-# RULES -"TEXT last -> fused" [~1] forall t. - last t = S.last (stream t) -"TEXT last -> unfused" [1] forall t. - S.last (stream t) = last t - #-} - -- | /O(1)/ Returns all characters after the head of a 'Text', which --- must be non-empty. Subject to fusion. +-- must be non-empty. tail :: Text -> Text tail t@(Text arr off len) | len <= 0 = emptyError "tail" @@ -536,15 +494,8 @@ tail t@(Text arr off len) where d = iter_ t 0 {-# INLINE [1] tail #-} -{-# RULES -"TEXT tail -> fused" [~1] forall t. - tail t = unstream (S.tail (stream t)) -"TEXT tail -> unfused" [1] forall t. - unstream (S.tail (stream t)) = tail t - #-} - -- | /O(1)/ Returns all but the last character of a 'Text', which must --- be non-empty. Subject to fusion. +-- be non-empty. init :: Text -> Text init (Text arr off len) | len <= 0 = emptyError "init" | n >= 0xDC00 && n <= 0xDFFF = text arr off (len-2) @@ -553,13 +504,6 @@ init (Text arr off len) | len <= 0 = emptyError "init" n = A.unsafeIndex arr (off+len-1) {-# INLINE [1] init #-} -{-# RULES -"TEXT init -> fused" [~1] forall t. - init t = unstream (S.init (stream t)) -"TEXT init -> unfused" [1] forall t. - unstream (S.init (stream t)) = init t - #-} - -- | /O(1)/ Returns all but the last character and the last character of a -- 'Text', or 'Nothing' if empty. -- @@ -573,8 +517,7 @@ unsnoc (Text arr off len) n0 = A.unsafeIndex arr (off+len-2) {-# INLINE [1] unsnoc #-} --- | /O(1)/ Tests whether a 'Text' is empty or not. Subject to --- fusion. +-- | /O(1)/ Tests whether a 'Text' is empty or not. null :: Text -> Bool null (Text _arr _off len) = #if defined(ASSERTS) @@ -583,21 +526,12 @@ null (Text _arr _off len) = len <= 0 {-# INLINE [1] null #-} -{-# RULES -"TEXT null -> fused" [~1] forall t. - null t = S.null (stream t) -"TEXT null -> unfused" [1] forall t. - S.null (stream t) = null t - #-} - -- | /O(1)/ Tests whether a 'Text' contains exactly one character. --- Subject to fusion. isSingleton :: Text -> Bool isSingleton = S.isSingleton . stream {-# INLINE isSingleton #-} -- | /O(n)/ Returns the number of characters in a 'Text'. --- Subject to fusion. length :: #if defined(ASSERTS) HasCallStack => @@ -609,7 +543,6 @@ length t = S.length (stream t) -- it may inline before the rules have an opportunity to fire. -- | /O(n)/ Compare the count of characters in a 'Text' to a number. --- Subject to fusion. -- -- This function gives the same answer as comparing against the result -- of 'length', but can short circuit if the count of characters is @@ -664,7 +597,7 @@ compareLength t n = S.compareLengthI (stream t) n -- >>> T.map (\c -> if c == '.' then '!' else c) message -- "I am not angry! Not at all!" -- --- Subject to fusion. Performs replacement on invalid scalar values. +-- Performs replacement on invalid scalar values. map :: (Char -> Char) -> Text -> Text map f t = unstream (S.map (safe . f) (stream t)) {-# INLINE [1] map #-} @@ -689,7 +622,7 @@ intercalate t = concat . (F.intersperse t) -- >>> T.intersperse '.' "SHIELD" -- "S.H.I.E.L.D" -- --- Subject to fusion. Performs replacement on invalid scalar values. +-- Performs replacement on invalid scalar values. intersperse :: Char -> Text -> Text intersperse c t = unstream (S.intersperse (safe c) (stream t)) {-# INLINE intersperse #-} @@ -700,8 +633,6 @@ intersperse c t = unstream (S.intersperse (safe c) (stream t)) -- -- >>> T.reverse "desrever" -- "reversed" --- --- Subject to fusion (fuses with its argument). reverse :: #if defined(ASSERTS) HasCallStack => @@ -786,7 +717,7 @@ replace needle@(Text _ _ neeLen) -- sensitivity should use appropriate versions of the -- . --- | /O(n)/ Convert a string to folded case. Subject to fusion. +-- | /O(n)/ Convert a string to folded case. -- -- This function is mainly useful for performing caseless (also known -- as case insensitive) string comparisons. @@ -807,7 +738,7 @@ toCaseFold t = unstream (S.toCaseFold (stream t)) {-# INLINE toCaseFold #-} -- | /O(n)/ Convert a string to lower case, using simple case --- conversion. Subject to fusion. +-- conversion. -- -- The result string may be longer than the input string. For -- instance, \"İ\" (Latin capital letter I with dot above, @@ -818,7 +749,7 @@ toLower t = unstream (S.toLower (stream t)) {-# INLINE toLower #-} -- | /O(n)/ Convert a string to upper case, using simple case --- conversion. Subject to fusion. +-- conversion. -- -- The result string may be longer than the input string. For -- instance, the German \"ß\" (eszett, U+00DF) maps to the @@ -828,7 +759,7 @@ toUpper t = unstream (S.toUpper (stream t)) {-# INLINE toUpper #-} -- | /O(n)/ Convert a string to title case, using simple case --- conversion. Subject to fusion. +-- conversion. -- -- The first letter of the input is converted to title case, as is -- every subsequent letter that immediately follows a non-letter. @@ -852,7 +783,7 @@ toTitle t = unstream (S.toTitle (stream t)) {-# INLINE toTitle #-} -- | /O(n)/ Left-justify a string to the given length, using the --- specified fill character on the right. Subject to fusion. +-- specified fill character on the right. -- Performs replacement on invalid scalar values. -- -- Examples: @@ -869,13 +800,6 @@ justifyLeft k c t where len = length t {-# INLINE [1] justifyLeft #-} -{-# RULES -"TEXT justifyLeft -> fused" [~1] forall k c t. - justifyLeft k c t = unstream (S.justifyLeftI k c (stream t)) -"TEXT justifyLeft -> unfused" [1] forall k c t. - unstream (S.justifyLeftI k c (stream t)) = justifyLeft k c t - #-} - -- | /O(n)/ Right-justify a string to the given length, using the -- specified fill character on the left. Performs replacement on -- invalid scalar values. @@ -933,23 +857,22 @@ transpose ts = P.map pack (L.transpose (P.map unpack ts)) -- | /O(n)/ 'foldl', applied to a binary operator, a starting value -- (typically the left-identity of the operator), and a 'Text', -- reduces the 'Text' using the binary operator, from left to right. --- Subject to fusion. foldl :: (a -> Char -> a) -> a -> Text -> a foldl f z t = S.foldl f z (stream t) {-# INLINE foldl #-} --- | /O(n)/ A strict version of 'foldl'. Subject to fusion. +-- | /O(n)/ A strict version of 'foldl'. foldl' :: (a -> Char -> a) -> a -> Text -> a foldl' f z t = S.foldl' f z (stream t) {-# INLINE foldl' #-} -- | /O(n)/ A variant of 'foldl' that has no starting value argument, --- and thus must be applied to a non-empty 'Text'. Subject to fusion. +-- and thus must be applied to a non-empty 'Text'. foldl1 :: (Char -> Char -> Char) -> Text -> Char foldl1 f t = S.foldl1 f (stream t) {-# INLINE foldl1 #-} --- | /O(n)/ A strict version of 'foldl1'. Subject to fusion. +-- | /O(n)/ A strict version of 'foldl1'. foldl1' :: (Char -> Char -> Char) -> Text -> Char foldl1' f t = S.foldl1' f (stream t) {-# INLINE foldl1' #-} @@ -957,14 +880,12 @@ foldl1' f t = S.foldl1' f (stream t) -- | /O(n)/ 'foldr', applied to a binary operator, a starting value -- (typically the right-identity of the operator), and a 'Text', -- reduces the 'Text' using the binary operator, from right to left. --- Subject to fusion. foldr :: (Char -> a -> a) -> a -> Text -> a foldr f z t = S.foldr f z (stream t) {-# INLINE foldr #-} -- | /O(n)/ A variant of 'foldr' that has no starting value argument, --- and thus must be applied to a non-empty 'Text'. Subject to --- fusion. +-- and thus must be applied to a non-empty 'Text'. foldr1 :: (Char -> Char -> Char) -> Text -> Char foldr1 f t = S.foldr1 f (stream t) {-# INLINE foldr1 #-} @@ -995,25 +916,25 @@ concatMap f = concat . foldr ((:) . f) [] {-# INLINE concatMap #-} -- | /O(n)/ 'any' @p@ @t@ determines whether any character in the --- 'Text' @t@ satisfies the predicate @p@. Subject to fusion. +-- 'Text' @t@ satisfies the predicate @p@. any :: (Char -> Bool) -> Text -> Bool any p t = S.any p (stream t) {-# INLINE any #-} -- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the --- 'Text' @t@ satisfy the predicate @p@. Subject to fusion. +-- 'Text' @t@ satisfy the predicate @p@. all :: (Char -> Bool) -> Text -> Bool all p t = S.all p (stream t) {-# INLINE all #-} -- | /O(n)/ 'maximum' returns the maximum value from a 'Text', which --- must be non-empty. Subject to fusion. +-- must be non-empty. maximum :: Text -> Char maximum t = S.maximum (stream t) {-# INLINE maximum #-} -- | /O(n)/ 'minimum' returns the minimum value from a 'Text', which --- must be non-empty. Subject to fusion. +-- must be non-empty. minimum :: Text -> Char minimum t = S.minimum (stream t) {-# INLINE minimum #-} @@ -1022,7 +943,7 @@ minimum t = S.minimum (stream t) -- * Building 'Text's -- | /O(n)/ 'scanl' is similar to 'foldl', but returns a list of --- successive reduced values from the left. Subject to fusion. +-- successive reduced values from the left. -- Performs replacement on invalid scalar values. -- -- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] @@ -1111,7 +1032,7 @@ replicate n t@(Text a o l) #-} -- | /O(n)/ 'replicateChar' @n@ @c@ is a 'Text' of length @n@ with @c@ the --- value of every element. Subject to fusion. +-- value of every element. replicateChar :: Int -> Char -> Text replicateChar n c = unstream (S.replicateCharI n (safe c)) {-# INLINE replicateChar #-} @@ -1121,8 +1042,8 @@ replicateChar n c = unstream (S.replicateCharI n (safe c)) -- 'Text' from a seed value. The function takes the element and -- returns 'Nothing' if it is done producing the 'Text', otherwise -- 'Just' @(a,b)@. In this case, @a@ is the next 'Char' in the --- string, and @b@ is the seed value for further production. Subject --- to fusion. Performs replacement on invalid scalar values. +-- string, and @b@ is the seed value for further production. +-- Performs replacement on invalid scalar values. unfoldr :: (a -> Maybe (Char,a)) -> a -> Text unfoldr f s = unstream (S.unfoldr (firstf safe . f) s) {-# INLINE unfoldr #-} @@ -1131,8 +1052,8 @@ unfoldr f s = unstream (S.unfoldr (firstf safe . f) s) -- value. However, the length of the result should be limited by the -- first argument to 'unfoldrN'. This function is more efficient than -- 'unfoldr' when the maximum length of the result is known and --- correct, otherwise its performance is similar to 'unfoldr'. Subject --- to fusion. Performs replacement on invalid scalar values. +-- correct, otherwise its performance is similar to 'unfoldr'. +-- Performs replacement on invalid scalar values. unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Text unfoldrN n f s = unstream (S.unfoldrN n (firstf safe . f) s) {-# INLINE unfoldrN #-} @@ -1142,7 +1063,7 @@ unfoldrN n f s = unstream (S.unfoldrN n (firstf safe . f) s) -- | /O(n)/ 'take' @n@, applied to a 'Text', returns the prefix of the -- 'Text' of length @n@, or the 'Text' itself if @n@ is greater than --- the length of the Text. Subject to fusion. +-- the length of the Text. take :: Int -> Text -> Text take n t@(Text arr off len) | n <= 0 = empty @@ -1157,13 +1078,6 @@ iterN n t@(Text _arr _off len) = loop 0 0 | otherwise = loop (i+d) (cnt+1) where d = iter_ t i -{-# RULES -"TEXT take -> fused" [~1] forall n t. - take n t = unstream (S.take n (stream t)) -"TEXT take -> unfused" [1] forall n t. - unstream (S.take n (stream t)) = take n t - #-} - -- | /O(n)/ 'takeEnd' @n@ @t@ returns the suffix remaining after -- taking @n@ characters from the end of @t@. -- @@ -1190,7 +1104,7 @@ iterNEnd n t@(Text _arr _off len) = loop (len-1) n -- | /O(n)/ 'drop' @n@, applied to a 'Text', returns the suffix of the -- 'Text' after the first @n@ characters, or the empty 'Text' if @n@ --- is greater than the length of the 'Text'. Subject to fusion. +-- is greater than the length of the 'Text'. drop :: Int -> Text -> Text drop n t@(Text arr off len) | n <= 0 = t @@ -1199,15 +1113,6 @@ drop n t@(Text arr off len) where i = iterN n t {-# INLINE [1] drop #-} -{-# RULES -"TEXT drop -> fused" [~1] forall n t. - drop n t = unstream (S.drop n (stream t)) -"TEXT drop -> unfused" [1] forall n t. - unstream (S.drop n (stream t)) = drop n t -"TEXT take . drop -> unfused" [1] forall len off t. - unstream (S.take len (S.drop off (stream t))) = take len (drop off t) - #-} - -- | /O(n)/ 'dropEnd' @n@ @t@ returns the prefix remaining after -- dropping @n@ characters from the end of @t@. -- @@ -1225,7 +1130,7 @@ dropEnd n t@(Text arr off len) -- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'Text', -- returns the longest prefix (possibly empty) of elements that --- satisfy @p@. Subject to fusion. +-- satisfy @p@. takeWhile :: (Char -> Bool) -> Text -> Text takeWhile p t@(Text arr off len) = loop 0 where loop !i | i >= len = t @@ -1234,13 +1139,6 @@ takeWhile p t@(Text arr off len) = loop 0 where Iter c d = iter t i {-# INLINE [1] takeWhile #-} -{-# RULES -"TEXT takeWhile -> fused" [~1] forall p t. - takeWhile p t = unstream (S.takeWhile p (stream t)) -"TEXT takeWhile -> unfused" [1] forall p t. - unstream (S.takeWhile p (stream t)) = takeWhile p t - #-} - -- | /O(n)/ 'takeWhileEnd', applied to a predicate @p@ and a 'Text', -- returns the longest suffix (possibly empty) of elements that -- satisfy @p@. @@ -1259,7 +1157,7 @@ takeWhileEnd p t@(Text arr off len) = loop (len-1) len {-# INLINE [1] takeWhileEnd #-} -- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after --- 'takeWhile' @p@ @t@. Subject to fusion. +-- 'takeWhile' @p@ @t@. dropWhile :: (Char -> Bool) -> Text -> Text dropWhile p t@(Text arr off len) = loop 0 0 where loop !i !l | l >= len = empty @@ -1268,13 +1166,6 @@ dropWhile p t@(Text arr off len) = loop 0 0 where Iter c d = iter t i {-# INLINE [1] dropWhile #-} -{-# RULES -"TEXT dropWhile -> fused" [~1] forall p t. - dropWhile p t = unstream (S.dropWhile p (stream t)) -"TEXT dropWhile -> unfused" [1] forall p t. - unstream (S.dropWhile p (stream t)) = dropWhile p t - #-} - -- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after -- dropping characters that satisfy the predicate @p@ from the end of -- @t@. @@ -1293,7 +1184,7 @@ dropWhileEnd p t@(Text arr off len) = loop (len-1) len -- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after -- dropping characters that satisfy the predicate @p@ from both the --- beginning and end of @t@. Subject to fusion. +-- beginning and end of @t@. dropAround :: (Char -> Bool) -> Text -> Text dropAround p = dropWhile p . dropWhileEnd p {-# INLINE [1] dropAround #-} @@ -1487,7 +1378,7 @@ elem c t = S.any (== c) (stream t) -- | /O(n)/ The 'find' function takes a predicate and a 'Text', and -- returns the first element matching the predicate, or 'Nothing' if --- there is no such element. Subject to fusion. +-- there is no such element. find :: (Char -> Bool) -> Text -> Maybe Char find p t = S.findBy p (stream t) {-# INLINE find #-} @@ -1603,14 +1494,14 @@ breakOnAll pat src@(Text arr off slen) -- searching for the index of @\"::\"@ and taking the substrings -- before and after that index, you would instead use @breakOnAll \"::\"@. --- | /O(n)/ 'Text' index (subscript) operator, starting from 0. Subject to fusion. +-- | /O(n)/ 'Text' index (subscript) operator, starting from 0. index :: Text -> Int -> Char index t n = S.index (stream t) n {-# INLINE index #-} -- | /O(n)/ The 'findIndex' function takes a predicate and a 'Text' -- and returns the index of the first element in the 'Text' satisfying --- the predicate. Subject to fusion. +-- the predicate. findIndex :: (Char -> Bool) -> Text -> Maybe Int findIndex p t = S.findIndex p (stream t) {-# INLINE findIndex #-} @@ -1634,7 +1525,7 @@ count pat src #-} -- | /O(n)/ The 'countChar' function returns the number of times the --- query element appears in the given 'Text'. Subject to fusion. +-- query element appears in the given 'Text'. countChar :: Char -> Text -> Int countChar c t = S.countChar c (stream t) {-# INLINE countChar #-} @@ -1719,17 +1610,12 @@ unwords = intercalate (singleton ' ') {-# INLINE unwords #-} -- | /O(n)/ The 'isPrefixOf' function takes two 'Text's and returns --- 'True' iff the first is a prefix of the second. Subject to fusion. +-- 'True' iff the first is a prefix of the second. isPrefixOf :: Text -> Text -> Bool isPrefixOf a@(Text _ _ alen) b@(Text _ _ blen) = alen <= blen && S.isPrefixOf (stream a) (stream b) {-# INLINE [1] isPrefixOf #-} -{-# RULES -"TEXT isPrefixOf -> fused" [~1] forall s t. - isPrefixOf s t = S.isPrefixOf (stream s) (stream t) - #-} - -- | /O(n)/ The 'isSuffixOf' function takes two 'Text's and returns -- 'True' iff the first is a suffix of the second. isSuffixOf :: Text -> Text -> Bool @@ -1757,11 +1643,6 @@ isInfixOf needle haystack | otherwise = not . L.null . indices needle $ haystack {-# INLINE [1] isInfixOf #-} -{-# RULES -"TEXT isInfixOf/singleton -> S.elem/S.stream" [~1] forall n h. - isInfixOf (singleton n) h = S.elem n (S.stream h) - #-} - ------------------------------------------------------------------------------- -- * View patterns diff --git a/src/Data/Text/Encoding.hs b/src/Data/Text/Encoding.hs index a7bc8a15..73675f70 100644 --- a/src/Data/Text/Encoding.hs +++ b/src/Data/Text/Encoding.hs @@ -375,8 +375,6 @@ streamDecodeUtf8With onErr = decodeChunk B.empty 0 0 decodeUtf8 :: ByteString -> Text decodeUtf8 = decodeUtf8With strictDecode {-# INLINE[0] decodeUtf8 #-} -{-# RULES "STREAM stream/decodeUtf8 fusion" [1] - forall bs. F.stream (decodeUtf8 bs) = E.streamUtf8 strictDecode bs #-} -- | Decode a 'ByteString' containing UTF-8 encoded text. -- diff --git a/src/Data/Text/Internal/Fusion/Common.hs b/src/Data/Text/Internal/Fusion/Common.hs index 8dc480b9..42c53128 100644 --- a/src/Data/Text/Internal/Fusion/Common.hs +++ b/src/Data/Text/Internal/Fusion/Common.hs @@ -217,7 +217,6 @@ append (Stream next0 s01 len1) (Stream next1 s02 len2) = {-# INLINE [0] append #-} -- | /O(1)/ Returns the first character of a Text, which must be non-empty. --- Subject to array fusion. head :: Stream Char -> Char head (Stream next s0 _len) = loop_head s0 where @@ -232,7 +231,7 @@ head_empty = streamError "head" "Empty stream" {-# NOINLINE head_empty #-} -- | /O(1)/ Returns the first character and remainder of a 'Stream --- Char', or 'Nothing' if empty. Subject to array fusion. +-- Char', or 'Nothing' if empty. uncons :: Stream Char -> Maybe (Char, Stream Char) uncons (Stream next s0 len) = loop_uncons s0 where @@ -311,7 +310,6 @@ lengthI (Stream next s0 _len) = loop_length 0 s0 {-# INLINE[0] lengthI #-} -- | /O(n)/ Compares the count of characters in a string to a number. --- Subject to fusion. -- -- This function gives the same answer as comparing against the result -- of 'lengthI', but can short circuit if the count of characters is @@ -566,7 +564,6 @@ foldr f z (Stream next s0 _len) = loop_foldr s0 -- | foldr1 is a variant of 'foldr' that has no starting value argument, -- and thus must be applied to non-empty streams. --- Subject to array fusion. foldr1 :: (Char -> Char -> Char) -> Stream Char -> Char foldr1 f (Stream next s0 _len) = loop0_foldr1 s0 where @@ -588,7 +585,7 @@ intercalate s = concat . (L.intersperse s) -- ---------------------------------------------------------------------------- -- ** Special folds --- | /O(n)/ Concatenate a list of streams. Subject to array fusion. +-- | /O(n)/ Concatenate a list of streams. concat :: [Stream Char] -> Stream Char concat = L.foldr append empty {-# INLINE [0] concat #-} diff --git a/src/Data/Text/Lazy.hs b/src/Data/Text/Lazy.hs index c6785ca6..5e333f59 100644 --- a/src/Data/Text/Lazy.hs +++ b/src/Data/Text/Lazy.hs @@ -37,9 +37,6 @@ module Data.Text.Lazy ( - -- * Fusion - -- $fusion - -- * Acceptable data -- $replacement @@ -236,31 +233,6 @@ import Text.Printf (PrintfArg, formatArg, formatString) import GHC.Stack (HasCallStack) #endif --- $fusion --- --- Most of the functions in this module are subject to /fusion/, --- meaning that a pipeline of such functions will usually allocate at --- most one 'Text' value. --- --- As an example, consider the following pipeline: --- --- > import Data.Text.Lazy as T --- > import Data.Text.Lazy.Encoding as E --- > import Data.ByteString.Lazy (ByteString) --- > --- > countChars :: ByteString -> Int --- > countChars = T.length . T.toUpper . E.decodeUtf8 --- --- From the type signatures involved, this looks like it should --- allocate one 'ByteString' value, and two 'Text' values. However, --- when a module is compiled with optimisation enabled under GHC, the --- two intermediate 'Text' values will be optimised away, and the --- function will be compiled down to a single loop over the source --- 'ByteString'. --- --- Functions that can be fused by the compiler are documented with the --- phrase \"Subject to fusion\". - -- $replacement -- -- A 'Text' value is a sequence of Unicode scalar values, as defined @@ -407,7 +379,7 @@ textDataType = mkDataType "Data.Text.Lazy.Text" [packConstr] -- | /O(n)/ Convert a 'String' into a 'Text'. -- --- Subject to fusion. Performs replacement on invalid scalar values. +-- Performs replacement on invalid scalar values. pack :: #if defined(ASSERTS) HasCallStack => @@ -417,7 +389,6 @@ pack = unstream . S.streamList . L.map safe {-# INLINE [1] pack #-} -- | /O(n)/ Convert a 'Text' into a 'String'. --- Subject to fusion. unpack :: #if defined(ASSERTS) HasCallStack => @@ -447,19 +418,12 @@ unpackCString# addr# = unstream (S.streamCString# addr#) unstream (S.streamList (L.map safe [a])) = Chunk (T.singleton a) Empty #-} --- | /O(1)/ Convert a character into a Text. Subject to fusion. +-- | /O(1)/ Convert a character into a Text. -- Performs replacement on invalid scalar values. singleton :: Char -> Text singleton c = Chunk (T.singleton c) Empty {-# INLINE [1] singleton #-} -{-# RULES -"LAZY TEXT singleton -> fused" [~1] forall c. - singleton c = unstream (S.singleton c) -"LAZY TEXT singleton -> unfused" [1] forall c. - unstream (S.singleton c) = singleton c - #-} - -- | /O(c)/ Convert a list of strict 'T.Text's into a lazy 'Text'. fromChunks :: [T.Text] -> Text fromChunks cs = L.foldr chunk Empty cs @@ -481,47 +445,26 @@ fromStrict t = chunk t Empty -- ----------------------------------------------------------------------------- -- * Basic functions --- | /O(1)/ Adds a character to the front of a 'Text'. Subject to fusion. +-- | /O(1)/ Adds a character to the front of a 'Text'. cons :: Char -> Text -> Text cons c t = Chunk (T.singleton c) t {-# INLINE [1] cons #-} infixr 5 `cons` -{-# RULES -"LAZY TEXT cons -> fused" [~1] forall c t. - cons c t = unstream (S.cons c (stream t)) -"LAZY TEXT cons -> unfused" [1] forall c t. - unstream (S.cons c (stream t)) = cons c t - #-} - -- | /O(n)/ Adds a character to the end of a 'Text'. This copies the --- entire array in the process, unless fused. Subject to fusion. +-- entire array in the process. snoc :: Text -> Char -> Text snoc t c = foldrChunks Chunk (singleton c) t {-# INLINE [1] snoc #-} -{-# RULES -"LAZY TEXT snoc -> fused" [~1] forall t c. - snoc t c = unstream (S.snoc (stream t) c) -"LAZY TEXT snoc -> unfused" [1] forall t c. - unstream (S.snoc (stream t) c) = snoc t c - #-} - --- | /O(n\/c)/ Appends one 'Text' to another. Subject to fusion. +-- | /O(n\/c)/ Appends one 'Text' to another. append :: Text -> Text -> Text append xs ys = foldrChunks Chunk ys xs {-# INLINE [1] append #-} -{-# RULES -"LAZY TEXT append -> fused" [~1] forall t1 t2. - append t1 t2 = unstream (S.append (stream t1) (stream t2)) -"LAZY TEXT append -> unfused" [1] forall t1 t2. - unstream (S.append (stream t1) (stream t2)) = append t1 t2 - #-} - -- | /O(1)/ Returns the first character and rest of a 'Text', or --- 'Nothing' if empty. Subject to fusion. +-- 'Nothing' if empty. uncons :: Text -> Maybe (Char, Text) uncons Empty = Nothing uncons (Chunk t ts) = Just (T.unsafeHead t, ts') @@ -530,27 +473,20 @@ uncons (Chunk t ts) = Just (T.unsafeHead t, ts') {-# INLINE uncons #-} -- | /O(1)/ Returns the first character of a 'Text', which must be --- non-empty. Subject to fusion. +-- non-empty. head :: Text -> Char head t = S.head (stream t) {-# INLINE head #-} -- | /O(1)/ Returns all characters after the head of a 'Text', which --- must be non-empty. Subject to fusion. +-- must be non-empty. tail :: Text -> Text tail (Chunk t ts) = chunk (T.tail t) ts tail Empty = emptyError "tail" {-# INLINE [1] tail #-} -{-# RULES -"LAZY TEXT tail -> fused" [~1] forall t. - tail t = unstream (S.tail (stream t)) -"LAZY TEXT tail -> unfused" [1] forall t. - unstream (S.tail (stream t)) = tail t - #-} - -- | /O(n\/c)/ Returns all but the last character of a 'Text', which must --- be non-empty. Subject to fusion. +-- be non-empty. init :: Text -> Text init (Chunk t0 ts0) = go t0 ts0 where go t (Chunk t' ts) = Chunk t (go t' ts) @@ -558,13 +494,6 @@ init (Chunk t0 ts0) = go t0 ts0 init Empty = emptyError "init" {-# INLINE [1] init #-} -{-# RULES -"LAZY TEXT init -> fused" [~1] forall t. - init t = unstream (S.init (stream t)) -"LAZY TEXT init -> unfused" [1] forall t. - unstream (S.init (stream t)) = init t - #-} - -- | /O(n\/c)/ Returns the 'init' and 'last' of a 'Text', or 'Nothing' if -- empty. -- @@ -576,28 +505,19 @@ unsnoc Empty = Nothing unsnoc ts@(Chunk _ _) = Just (init ts, last ts) {-# INLINE unsnoc #-} --- | /O(1)/ Tests whether a 'Text' is empty or not. Subject to --- fusion. +-- | /O(1)/ Tests whether a 'Text' is empty or not. null :: Text -> Bool null Empty = True null _ = False {-# INLINE [1] null #-} -{-# RULES -"LAZY TEXT null -> fused" [~1] forall t. - null t = S.null (stream t) -"LAZY TEXT null -> unfused" [1] forall t. - S.null (stream t) = null t - #-} - -- | /O(1)/ Tests whether a 'Text' contains exactly one character. --- Subject to fusion. isSingleton :: Text -> Bool isSingleton = S.isSingleton . stream {-# INLINE isSingleton #-} -- | /O(n\/c)/ Returns the last character of a 'Text', which must be --- non-empty. Subject to fusion. +-- non-empty. last :: Text -> Char last Empty = emptyError "last" last (Chunk t ts) = go t ts @@ -605,15 +525,7 @@ last (Chunk t ts) = go t ts go t' Empty = T.last t' {-# INLINE [1] last #-} -{-# RULES -"LAZY TEXT last -> fused" [~1] forall t. - last t = S.last (stream t) -"LAZY TEXT last -> unfused" [1] forall t. - S.last (stream t) = last t - #-} - -- | /O(n)/ Returns the number of characters in a 'Text'. --- Subject to fusion. length :: Text -> Int64 length = foldlChunks go 0 where @@ -621,15 +533,7 @@ length = foldlChunks go 0 go l t = l + intToInt64 (T.length t) {-# INLINE [1] length #-} -{-# RULES -"LAZY TEXT length -> fused" [~1] forall t. - length t = S.length (stream t) -"LAZY TEXT length -> unfused" [1] forall t. - S.length (stream t) = length t - #-} - -- | /O(n)/ Compare the count of characters in a 'Text' to a number. --- Subject to fusion. -- -- This function gives the same answer as comparing against the result -- of 'length', but can short circuit if the count of characters is @@ -643,7 +547,7 @@ compareLength t n = S.compareLengthI (stream t) n -- properties of code. -- | /O(n)/ 'map' @f@ @t@ is the 'Text' obtained by applying @f@ to --- each element of @t@. Subject to fusion. Performs replacement on +-- each element of @t@. Performs replacement on -- invalid scalar values. map :: (Char -> Char) -> Text -> Text map f t = unstream (S.map (safe . f) (stream t)) @@ -657,14 +561,14 @@ intercalate t = concat . (F.intersperse t) {-# INLINE intercalate #-} -- | /O(n)/ The 'intersperse' function takes a character and places it --- between the characters of a 'Text'. Subject to fusion. Performs +-- between the characters of a 'Text'. Performs -- replacement on invalid scalar values. intersperse :: Char -> Text -> Text intersperse c t = unstream (S.intersperse (safe c) (stream t)) {-# INLINE intersperse #-} -- | /O(n)/ Left-justify a string to the given length, using the --- specified fill character on the right. Subject to fusion. Performs +-- specified fill character on the right. Performs -- replacement on invalid scalar values. -- -- Examples: @@ -678,13 +582,6 @@ justifyLeft k c t where len = length t {-# INLINE [1] justifyLeft #-} -{-# RULES -"LAZY TEXT justifyLeft -> fused" [~1] forall k c t. - justifyLeft k c t = unstream (S.justifyLeftI k c (stream t)) -"LAZY TEXT justifyLeft -> unfused" [1] forall k c t. - unstream (S.justifyLeftI k c (stream t)) = justifyLeft k c t - #-} - -- | /O(n)/ Right-justify a string to the given length, using the -- specified fill character on the left. Performs replacement on -- invalid scalar values. @@ -782,7 +679,7 @@ replace s d = intercalate d . splitOn s -- functions may map one input character to two or three output -- characters. --- | /O(n)/ Convert a string to folded case. Subject to fusion. +-- | /O(n)/ Convert a string to folded case. -- -- This function is mainly useful for performing caseless (or case -- insensitive) string comparisons. @@ -802,7 +699,7 @@ toCaseFold t = unstream (S.toCaseFold (stream t)) {-# INLINE toCaseFold #-} -- | /O(n)/ Convert a string to lower case, using simple case --- conversion. Subject to fusion. +-- conversion. -- -- The result string may be longer than the input string. For -- instance, the Latin capital letter I with dot above (U+0130) maps @@ -813,7 +710,7 @@ toLower t = unstream (S.toLower (stream t)) {-# INLINE toLower #-} -- | /O(n)/ Convert a string to upper case, using simple case --- conversion. Subject to fusion. +-- conversion. -- -- The result string may be longer than the input string. For -- instance, the German eszett (U+00DF) maps to the two-letter @@ -824,7 +721,7 @@ toUpper t = unstream (S.toUpper (stream t)) -- | /O(n)/ Convert a string to title case, using simple case --- conversion. Subject to fusion. +-- conversion. -- -- The first letter of the input is converted to title case, as is -- every subsequent letter that immediately follows a non-letter. @@ -850,24 +747,23 @@ toTitle t = unstream (S.toTitle (stream t)) -- | /O(n)/ 'foldl', applied to a binary operator, a starting value -- (typically the left-identity of the operator), and a 'Text', -- reduces the 'Text' using the binary operator, from left to right. --- Subject to fusion. foldl :: (a -> Char -> a) -> a -> Text -> a foldl f z t = S.foldl f z (stream t) {-# INLINE foldl #-} -- | /O(n)/ A strict version of 'foldl'. --- Subject to fusion. +-- foldl' :: (a -> Char -> a) -> a -> Text -> a foldl' f z t = S.foldl' f z (stream t) {-# INLINE foldl' #-} -- | /O(n)/ A variant of 'foldl' that has no starting value argument, --- and thus must be applied to a non-empty 'Text'. Subject to fusion. +-- and thus must be applied to a non-empty 'Text'. foldl1 :: (Char -> Char -> Char) -> Text -> Char foldl1 f t = S.foldl1 f (stream t) {-# INLINE foldl1 #-} --- | /O(n)/ A strict version of 'foldl1'. Subject to fusion. +-- | /O(n)/ A strict version of 'foldl1'. foldl1' :: (Char -> Char -> Char) -> Text -> Char foldl1' f t = S.foldl1' f (stream t) {-# INLINE foldl1' #-} @@ -875,14 +771,12 @@ foldl1' f t = S.foldl1' f (stream t) -- | /O(n)/ 'foldr', applied to a binary operator, a starting value -- (typically the right-identity of the operator), and a 'Text', -- reduces the 'Text' using the binary operator, from right to left. --- Subject to fusion. foldr :: (Char -> a -> a) -> a -> Text -> a foldr f z t = S.foldr f z (stream t) {-# INLINE foldr #-} -- | /O(n)/ A variant of 'foldr' that has no starting value argument, --- and thus must be applied to a non-empty 'Text'. Subject to --- fusion. +-- and thus must be applied to a non-empty 'Text'. foldr1 :: (Char -> Char -> Char) -> Text -> Char foldr1 f t = S.foldr1 f (stream t) {-# INLINE foldr1 #-} @@ -904,31 +798,31 @@ concatMap f = concat . foldr ((:) . f) [] {-# INLINE concatMap #-} -- | /O(n)/ 'any' @p@ @t@ determines whether any character in the --- 'Text' @t@ satisfies the predicate @p@. Subject to fusion. +-- 'Text' @t@ satisfies the predicate @p@. any :: (Char -> Bool) -> Text -> Bool any p t = S.any p (stream t) {-# INLINE any #-} -- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the --- 'Text' @t@ satisfy the predicate @p@. Subject to fusion. +-- 'Text' @t@ satisfy the predicate @p@. all :: (Char -> Bool) -> Text -> Bool all p t = S.all p (stream t) {-# INLINE all #-} -- | /O(n)/ 'maximum' returns the maximum value from a 'Text', which --- must be non-empty. Subject to fusion. +-- must be non-empty. maximum :: Text -> Char maximum t = S.maximum (stream t) {-# INLINE maximum #-} -- | /O(n)/ 'minimum' returns the minimum value from a 'Text', which --- must be non-empty. Subject to fusion. +-- must be non-empty. minimum :: Text -> Char minimum t = S.minimum (stream t) {-# INLINE minimum #-} -- | /O(n)/ 'scanl' is similar to 'foldl', but returns a list of --- successive reduced values from the left. Subject to fusion. +-- successive reduced values from the left. -- Performs replacement on invalid scalar values. -- -- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] @@ -1031,7 +925,7 @@ iterate f c = let t c' = Chunk (T.singleton c') (t (f c')) in t c -- | /O(n)/ 'replicateChar' @n@ @c@ is a 'Text' of length @n@ with @c@ the --- value of every element. Subject to fusion. +-- value of every element. replicateChar :: Int64 -> Char -> Text replicateChar n c = unstream (S.replicateCharI n (safe c)) {-# INLINE replicateChar #-} @@ -1039,8 +933,6 @@ replicateChar n c = unstream (S.replicateCharI n (safe c)) {-# RULES "LAZY TEXT replicate/singleton -> replicateChar" [~1] forall n c. replicate n (singleton c) = replicateChar n c -"LAZY TEXT replicate/unstream/singleton -> replicateChar" [~1] forall n c. - replicate n (unstream (S.singleton c)) = replicateChar n c #-} -- | /O(n)/, where @n@ is the length of the result. The 'unfoldr' @@ -1049,7 +941,6 @@ replicateChar n c = unstream (S.replicateCharI n (safe c)) -- returns 'Nothing' if it is done producing the 'Text', otherwise -- 'Just' @(a,b)@. In this case, @a@ is the next 'Char' in the -- string, and @b@ is the seed value for further production. --- Subject to fusion. -- Performs replacement on invalid scalar values. unfoldr :: (a -> Maybe (Char,a)) -> a -> Text unfoldr f s = unstream (S.unfoldr (firstf safe . f) s) @@ -1060,7 +951,6 @@ unfoldr f s = unstream (S.unfoldr (firstf safe . f) s) -- first argument to 'unfoldrN'. This function is more efficient than -- 'unfoldr' when the maximum length of the result is known and -- correct, otherwise its performance is similar to 'unfoldr'. --- Subject to fusion. -- Performs replacement on invalid scalar values. unfoldrN :: Int64 -> (a -> Maybe (Char,a)) -> a -> Text unfoldrN n f s = unstream (S.unfoldrN n (firstf safe . f) s) @@ -1068,7 +958,7 @@ unfoldrN n f s = unstream (S.unfoldrN n (firstf safe . f) s) -- | /O(n)/ 'take' @n@, applied to a 'Text', returns the prefix of the -- 'Text' of length @n@, or the 'Text' itself if @n@ is greater than --- the length of the Text. Subject to fusion. +-- the length of the Text. take :: Int64 -> Text -> Text take i _ | i <= 0 = Empty take i t0 = take' i t0 @@ -1082,13 +972,6 @@ take i t0 = take' i t0 where len = intToInt64 (T.length t) {-# INLINE [1] take #-} -{-# RULES -"LAZY TEXT take -> fused" [~1] forall n t. - take n t = unstream (S.take n (stream t)) -"LAZY TEXT take -> unfused" [1] forall n t. - unstream (S.take n (stream t)) = take n t - #-} - -- | /O(n)/ 'takeEnd' @n@ @t@ returns the suffix remaining after -- taking @n@ characters from the end of @t@. -- @@ -1111,7 +994,7 @@ takeEnd n t0 -- | /O(n)/ 'drop' @n@, applied to a 'Text', returns the suffix of the -- 'Text' after the first @n@ characters, or the empty 'Text' if @n@ --- is greater than the length of the 'Text'. Subject to fusion. +-- is greater than the length of the 'Text'. drop :: Int64 -> Text -> Text drop i t0 | i <= 0 = t0 @@ -1126,13 +1009,6 @@ drop i t0 where len = intToInt64 (T.length t) {-# INLINE [1] drop #-} -{-# RULES -"LAZY TEXT drop -> fused" [~1] forall n t. - drop n t = unstream (S.drop n (stream t)) -"LAZY TEXT drop -> unfused" [1] forall n t. - unstream (S.drop n (stream t)) = drop n t - #-} - -- | /O(n)/ 'dropEnd' @n@ @t@ returns the prefix remaining after -- dropping @n@ characters from the end of @t@. -- @@ -1173,7 +1049,7 @@ dropWords i t0 -- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'Text', -- returns the longest prefix (possibly empty) of elements that --- satisfy @p@. Subject to fusion. +-- satisfy @p@. takeWhile :: (Char -> Bool) -> Text -> Text takeWhile p t0 = takeWhile' t0 where takeWhile' Empty = Empty @@ -1184,12 +1060,6 @@ takeWhile p t0 = takeWhile' t0 Nothing -> Chunk t (takeWhile' ts) {-# INLINE [1] takeWhile #-} -{-# RULES -"LAZY TEXT takeWhile -> fused" [~1] forall p t. - takeWhile p t = unstream (S.takeWhile p (stream t)) -"LAZY TEXT takeWhile -> unfused" [1] forall p t. - unstream (S.takeWhile p (stream t)) = takeWhile p t - #-} -- | /O(n)/ 'takeWhileEnd', applied to a predicate @p@ and a 'Text', -- returns the longest suffix (possibly empty) of elements that -- satisfy @p@. @@ -1209,7 +1079,7 @@ takeWhileEnd p = takeChunk empty . L.reverse . toChunks {-# INLINE takeWhileEnd #-} -- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after --- 'takeWhile' @p@ @t@. Subject to fusion. +-- 'takeWhile' @p@ @t@. dropWhile :: (Char -> Bool) -> Text -> Text dropWhile p t0 = dropWhile' t0 where dropWhile' Empty = Empty @@ -1219,13 +1089,6 @@ dropWhile p t0 = dropWhile' t0 Nothing -> dropWhile' ts {-# INLINE [1] dropWhile #-} -{-# RULES -"LAZY TEXT dropWhile -> fused" [~1] forall p t. - dropWhile p t = unstream (S.dropWhile p (stream t)) -"LAZY TEXT dropWhile -> unfused" [1] forall p t. - unstream (S.dropWhile p (stream t)) = dropWhile p t - #-} - -- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after -- dropping characters that satisfy the predicate @p@ from the end of -- @t@. @@ -1550,7 +1413,7 @@ unwords = intercalate (singleton ' ') {-# INLINE unwords #-} -- | /O(n)/ The 'isPrefixOf' function takes two 'Text's and returns --- 'True' iff the first is a prefix of the second. Subject to fusion. +-- 'True' iff the first is a prefix of the second. isPrefixOf :: Text -> Text -> Bool isPrefixOf Empty _ = True isPrefixOf _ Empty = False @@ -1564,13 +1427,6 @@ isPrefixOf (Chunk x xs) (Chunk y ys) ly = T.length y {-# INLINE [1] isPrefixOf #-} -{-# RULES -"LAZY TEXT isPrefixOf -> fused" [~1] forall s t. - isPrefixOf s t = S.isPrefixOf (stream s) (stream t) -"LAZY TEXT isPrefixOf -> unfused" [1] forall s t. - S.isPrefixOf (stream s) (stream t) = isPrefixOf s t - #-} - -- | /O(n)/ The 'isSuffixOf' function takes two 'Text's and returns -- 'True' iff the first is a suffix of the second. isSuffixOf :: Text -> Text -> Bool @@ -1594,11 +1450,6 @@ isInfixOf needle haystack | otherwise = not . L.null . indices needle $ haystack {-# INLINE [1] isInfixOf #-} -{-# RULES -"LAZY TEXT isInfixOf/singleton -> S.elem/S.stream" [~1] forall n h. - isInfixOf (singleton n) h = S.elem n (S.stream h) - #-} - ------------------------------------------------------------------------------- -- * View patterns @@ -1683,7 +1534,7 @@ filter p t = unstream (S.filter p (stream t)) -- | /O(n)/ The 'find' function takes a predicate and a 'Text', and -- returns the first element in matching the predicate, or 'Nothing' --- if there is no such element. Subject to fusion. +-- if there is no such element. find :: (Char -> Bool) -> Text -> Maybe Char find p t = S.findBy p (stream t) {-# INLINE find #-} @@ -1705,7 +1556,6 @@ partition p t = (filter p t, filter (not . p) t) {-# INLINE partition #-} -- | /O(n)/ 'Text' index (subscript) operator, starting from 0. --- Subject to fusion. index :: Text -> Int64 -> Char index t n = S.index (stream t) n {-# INLINE index #-} @@ -1730,7 +1580,7 @@ count pat src #-} -- | /O(n)/ The 'countChar' function returns the number of times the --- query element appears in the given 'Text'. Subject to fusion. +-- query element appears in the given 'Text'. countChar :: Char -> Text -> Int64 countChar c t = S.countChar c (stream t) diff --git a/src/Data/Text/Lazy/Encoding.hs b/src/Data/Text/Lazy/Encoding.hs index 60de7d1a..d10e074d 100644 --- a/src/Data/Text/Lazy/Encoding.hs +++ b/src/Data/Text/Lazy/Encoding.hs @@ -59,7 +59,6 @@ import qualified Data.ByteString.Builder.Extra as B (safeStrategy, toLazyByteStr 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.ByteString.Unsafe as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Internal.Lazy.Encoding.Fusion as E @@ -121,10 +120,6 @@ decodeUtf8 :: B.ByteString -> Text decodeUtf8 = decodeUtf8With strictDecode {-# INLINE[0] decodeUtf8 #-} --- This rule seems to cause performance loss. -{- RULES "LAZY STREAM stream/decodeUtf8' fusion" [1] - forall bs. F.stream (decodeUtf8' bs) = E.streamUtf8 strictDecode bs #-} - -- | Decode a 'ByteString' containing UTF-8 encoded text.. -- -- If the input contains any invalid UTF-8 data, the relevant diff --git a/src/Data/Text/Show.hs b/src/Data/Text/Show.hs index c6b296b0..8d7ceb0e 100644 --- a/src/Data/Text/Show.hs +++ b/src/Data/Text/Show.hs @@ -36,7 +36,7 @@ import GHC.Stack (HasCallStack) instance Show Text where showsPrec p ps r = showsPrec p (unpack ps) r --- | /O(n)/ Convert a 'Text' into a 'String'. Subject to fusion. +-- | /O(n)/ Convert a 'Text' into a 'String'. unpack :: #if defined(ASSERTS) HasCallStack => @@ -70,7 +70,7 @@ unpackCString# addr# = unstream (S.streamCString# addr#) unstream (S.map safe (S.streamList [a])) = singleton_ a #-} --- | /O(1)/ Convert a character into a Text. Subject to fusion. +-- | /O(1)/ Convert a character into a Text. -- Performs replacement on invalid scalar values. singleton :: #if defined(ASSERTS) diff --git a/tests/Tests.hs b/tests/Tests.hs index 5d8c8a86..98d1ec00 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -10,18 +10,9 @@ import qualified Tests.Lift as Lift import qualified Tests.Properties as Properties import qualified Tests.Regressions as Regressions -#if !defined(ASSERTS) -import qualified Tests.Inspection.Strict as InspectionStrict -import qualified Tests.Inspection.Lazy as InspectionLazy -#endif - main :: IO () main = defaultMain $ testGroup "All" [ Lift.tests , Properties.tests , Regressions.tests -#if !defined(ASSERTS) - , InspectionStrict.tests - , InspectionLazy.tests -#endif ] diff --git a/tests/Tests/Inspection/Lazy.hs b/tests/Tests/Inspection/Lazy.hs deleted file mode 100644 index f30a24e3..00000000 --- a/tests/Tests/Inspection/Lazy.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -O -fno-warn-unused-top-binds -fno-warn-missing-signatures -fno-warn-name-shadowing -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-} - -module Tests.Inspection.Lazy (tests) where - -import Prelude hiding (all, any, drop, dropWhile, filter, foldl, foldl1, foldr, foldr1, head, init, iterate, last, length, map, maximum, minimum, null, replicate, reverse, scanl, scanl1, scanr, scanr1, tail, take, takeWhile) -import Data.Char (isAscii) - -import qualified Data.Text.Lazy as T - -import Test.Tasty -import Test.Tasty.Inspection - -maximum_unfoldr = T.maximum . unfoldr -isPrefixOf_unfoldr = isPrefixOf . unfoldr -any_filter_init_pack = any . filter . T.init . T.pack -isPrefixOf_intersperse_unfoldr = isPrefixOf . intersperse . unfoldr -compareLength_take_pack = compareLength . take . T.pack -index_toCaseFold_singleton = index . T.toCaseFold . T.singleton -unpack_take_pack = T.unpack . take . T.pack -foldl_singleton = foldl . T.singleton -foldr_filter_singleton = foldr . filter . T.singleton -foldr1_stripStart_singleton = foldr1 . T.stripStart . T.singleton -foldl_drop_singleton = foldl . drop . T.singleton -all_toCaseFold_unfoldr = all . T.toCaseFold . unfoldr -foldl_pack = foldl . T.pack -last_toUpper_toLower_unfoldrN = T.last . T.toUpper . T.toLower . unfoldrN -null_map_unfoldr = T.null . map . unfoldr -any_toTitle_tail_unfoldrN = any . T.toTitle . T.tail . unfoldrN -head_filter_pack = T.head . filter . T.pack -foldr1_toTitle_stripStart_singleton = foldr1 . T.toTitle . T.stripStart . T.singleton -compareLength_snoc_unfoldr = compareLength . snoc . unfoldr -compareLength_intersperse_toUpper_unfoldr = compareLength . intersperse . T.toUpper . unfoldr -compareLength_takeWhile_intersperse_unfoldr = compareLength . takeWhile . intersperse . unfoldr -all_init_map_unfoldrN = all . T.init . map . unfoldrN -foldr_scanl_unfoldrN = foldr . scanl . unfoldrN -compareLength_pack = compareLength . T.pack -foldr_cons_singleton = foldr . cons . T.singleton -last_tail_unfoldrN = T.last . T.tail . unfoldrN -foldr1_take_unfoldr = foldr1 . take . unfoldr -null_unfoldrN = T.null . unfoldrN -foldr1_init_singleton = foldr1 . T.init . T.singleton -all_cons_dropWhile_singleton = all . cons . dropWhile . T.singleton -head_append_toTitle_singleton = T.head . append . T.toTitle . T.singleton -foldl1_tail_intersperse_unfoldr = foldl1 . T.tail . intersperse . unfoldr -foldr1_drop_singleton = foldr1 . drop . T.singleton -minimum_tail_pack = T.minimum . T.tail . T.pack -minimum_pack = T.minimum . T.pack -length_takeWhile_singleton = T.length . takeWhile . T.singleton -foldl_take_toCaseFold_unfoldr = foldl . take . T.toCaseFold . unfoldr -foldr_intersperse_singleton = foldr . intersperse . T.singleton -compareLength_cons_snoc_singleton = compareLength . cons . snoc . T.singleton -last_map_append_unfoldrN = T.last . map . append . unfoldrN -find_justifyLeft_takeWhile_pack = find . justifyLeft . takeWhile . T.pack -head_append_unfoldr = T.head . append . unfoldr -minimum_justifyLeft_drop_unfoldrN = T.minimum . justifyLeft . drop . unfoldrN -null_singleton = T.null . T.singleton -last_map_justifyLeft_pack = T.last . map . justifyLeft . T.pack -foldl1'_tail_unfoldrN = foldl1' . T.tail . unfoldrN -maximum_take_unfoldrN = T.maximum . take . unfoldrN -foldl'_unfoldrN = foldl' . unfoldrN -foldl1'_filter_intersperse_singleton = foldl1' . filter . intersperse . T.singleton -length_singleton = T.length . T.singleton -foldr1_pack = foldr1 . T.pack -foldl1'_singleton = foldl1' . T.singleton -foldr1_scanl_singleton = foldr1 . scanl . T.singleton -minimum_tail_singleton = T.minimum . T.tail . T.singleton -any_pack = any . T.pack -length_pack = T.length . T.pack -head_unfoldrN = T.head . unfoldrN -head_map_pack = T.head . map . T.pack -foldr_stripStart_toCaseFold_singleton = foldr . T.stripStart . T.toCaseFold . T.singleton -any_append_pack = any . append . T.pack -all_drop_toUpper_unfoldrN = all . drop . T.toUpper . unfoldrN -foldl1'_filter_filter_unfoldr = foldl1' . filter . filter . unfoldr -any_singleton = any . T.singleton -any_toTitle_scanl_unfoldr = any . T.toTitle . scanl . unfoldr -foldr1_cons_pack = foldr1 . cons . T.pack -foldl1'_toTitle_dropWhile_singleton = foldl1' . T.toTitle . dropWhile . T.singleton -length_justifyLeft_unfoldr = T.length . justifyLeft . unfoldr -foldl1'_justifyLeft_pack = foldl1' . justifyLeft . T.pack -foldr_map_toTitle_unfoldrN = foldr . map . T.toTitle . unfoldrN -head_singleton = T.head . T.singleton -foldl'_singleton = foldl' . T.singleton -foldr1_dropWhile_intersperse_pack = foldr1 . dropWhile . intersperse . T.pack -foldl1'_pack = foldl1' . T.pack -head_replicate_singleton = T.head . replicate . T.singleton -unpack_toUpper_snoc_singleton = T.unpack . T.toUpper . snoc . T.singleton -null_empty = T.null . empty -maximum_singleton = T.maximum . T.singleton -isPrefixOf_init_singleton = isPrefixOf . T.init . T.singleton -minimum_unfoldr = T.minimum . unfoldr -foldl_stripStart_snoc_singleton = foldl . T.stripStart . snoc . T.singleton -any_toUpper_unfoldr = any . T.toUpper . unfoldr -all_unfoldr = all . unfoldr -minimum_toLower_unfoldrN = T.minimum . T.toLower . unfoldrN -null_pack = T.null . T.pack -index_dropWhile_unfoldr = index . dropWhile . unfoldr -minimum_filter_toUpper_singleton = T.minimum . filter . T.toUpper . T.singleton -head_pack = T.head . T.pack -foldl1'_toTitle_singleton = foldl1' . T.toTitle . T.singleton -find_unfoldr = find . unfoldr -isPrefixOf_unfoldrN = isPrefixOf . unfoldrN -unpack_append_pack = T.unpack . append . T.pack -any_unfoldr = any . unfoldr -length_unfoldrN = T.length . unfoldrN -minimum_singleton = T.minimum . T.singleton -head_snoc_toUpper_singleton = T.head . snoc . T.toUpper . T.singleton -maximum_unfoldrN = T.maximum . unfoldrN -all_take_pack = all . take . T.pack -isPrefixOf_pack = isPrefixOf . T.pack -foldr_init_pack = foldr . T.init . T.pack -foldl1'_filter_pack = foldl1' . filter . T.pack - -tests :: TestTree -tests = testGroup "Lazy fusion" [$(inspectNames (`hasNoType` ''T.Text) - ['maximum_unfoldr, 'isPrefixOf_unfoldr, 'any_filter_init_pack, 'isPrefixOf_intersperse_unfoldr, 'compareLength_take_pack, 'index_toCaseFold_singleton, 'unpack_take_pack, 'foldl_singleton, 'foldr_filter_singleton, 'foldr1_stripStart_singleton, 'foldl_drop_singleton, 'all_toCaseFold_unfoldr, 'foldl_pack, 'last_toUpper_toLower_unfoldrN, 'null_map_unfoldr, 'any_toTitle_tail_unfoldrN, 'head_filter_pack, 'foldr1_toTitle_stripStart_singleton, 'compareLength_snoc_unfoldr, 'compareLength_intersperse_toUpper_unfoldr, 'compareLength_takeWhile_intersperse_unfoldr, 'all_init_map_unfoldrN, 'foldr_scanl_unfoldrN, 'compareLength_pack, 'foldr_cons_singleton, 'last_tail_unfoldrN, 'foldr1_take_unfoldr, 'null_unfoldrN, 'foldr1_init_singleton, 'all_cons_dropWhile_singleton, 'head_append_toTitle_singleton, 'foldl1_tail_intersperse_unfoldr, 'foldr1_drop_singleton, 'minimum_tail_pack, 'minimum_pack, 'length_takeWhile_singleton, 'foldl_take_toCaseFold_unfoldr, 'foldr_intersperse_singleton, 'compareLength_cons_snoc_singleton, 'last_map_append_unfoldrN, 'find_justifyLeft_takeWhile_pack, 'head_append_unfoldr, 'minimum_justifyLeft_drop_unfoldrN, 'null_singleton, 'last_map_justifyLeft_pack, 'foldl1'_tail_unfoldrN, 'maximum_take_unfoldrN, 'foldl'_unfoldrN, 'foldl1'_filter_intersperse_singleton, 'length_singleton, 'foldr1_pack, 'foldl1'_singleton, 'foldr1_scanl_singleton, 'minimum_tail_singleton, 'any_pack, 'length_pack, 'head_unfoldrN, 'head_map_pack, 'foldr_stripStart_toCaseFold_singleton, 'any_append_pack, 'all_drop_toUpper_unfoldrN, 'foldl1'_filter_filter_unfoldr, 'any_singleton, 'any_toTitle_scanl_unfoldr, 'foldr1_cons_pack, 'foldl1'_toTitle_dropWhile_singleton, 'length_justifyLeft_unfoldr, 'foldl1'_justifyLeft_pack, 'foldr_map_toTitle_unfoldrN, 'head_singleton, 'foldl'_singleton, 'foldr1_dropWhile_intersperse_pack, 'foldl1'_pack, 'head_replicate_singleton, 'unpack_toUpper_snoc_singleton, 'null_empty, 'maximum_singleton, 'isPrefixOf_init_singleton, 'minimum_unfoldr, 'foldl_stripStart_snoc_singleton, 'any_toUpper_unfoldr, 'all_unfoldr, 'minimum_toLower_unfoldrN, 'null_pack, 'index_dropWhile_unfoldr, 'minimum_filter_toUpper_singleton, 'head_pack, 'foldl1'_toTitle_singleton, 'find_unfoldr, 'isPrefixOf_unfoldrN, 'unpack_append_pack, 'any_unfoldr, 'length_unfoldrN, 'minimum_singleton, 'head_snoc_toUpper_singleton, 'maximum_unfoldrN, 'all_take_pack, 'isPrefixOf_pack, 'foldr_init_pack, 'foldl1'_filter_pack])] - ---------------------------------------------------------------------------------- --- Definitions below are from inspection-testing package by Joachim Breitner. --- - -i = 42 -{-# NOINLINE i #-} - -empty _ = T.empty -{-# INLINE empty #-} -take x = T.take i x -{-# INLINE take #-} -drop x = T.drop i x -{-# INLINE drop #-} -cons x = 'x' `T.cons` x -{-# INLINE cons #-} -snoc x = x `T.snoc` 'x' -{-# INLINE snoc #-} -map x = T.map succ x -{-# INLINE map #-} -justifyLeft x = T.justifyLeft 42 'x' x -{-# INLINE justifyLeft #-} -intersperse x = T.intersperse 'x' x -{-# INLINE intersperse #-} -append x = unfoldrN 'y' `T.append` x -{-# INLINE append #-} -isPrefixOf x = unfoldrN 'a' `T.isPrefixOf` x -{-# INLINE isPrefixOf #-} -compareLength x = x `T.compareLength` i -{-# INLINE compareLength #-} -foldl x = T.foldl (\x c -> x + fromEnum c) 0 x -{-# INLINE foldl #-} -foldl' x = T.foldl' (\x c -> x + fromEnum c) 0 x -{-# INLINE foldl' #-} -foldl1 x = T.foldl1 (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x -{-# INLINE foldl1 #-} -foldl1' x = T.foldl1' (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x -{-# INLINE foldl1' #-} -foldr x = T.foldr (\c x -> x + fromEnum c) 0 x -{-# INLINE foldr #-} -foldr1 x = T.foldr1 (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x -{-# INLINE foldr1 #-} -any x = T.any isAscii x -{-# INLINE any #-} -all x = T.all isAscii x -{-# INLINE all #-} -scanl x = T.scanl (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) 'x' x -{-# INLINE scanl #-} -unfoldr x = T.unfoldr (\c -> if c == 'z' then Nothing else Just (c, succ c)) x -{-# INLINE unfoldr #-} -unfoldrN x = T.unfoldrN i (\c -> if c == 'z' then Nothing else Just (c, succ c)) x -{-# INLINE unfoldrN #-} -takeWhile x = T.takeWhile isAscii x -{-# INLINE takeWhile #-} -dropWhile x = T.dropWhile isAscii x -{-# INLINE dropWhile #-} -filter x = T.filter isAscii x -{-# INLINE filter #-} -find x = T.find isAscii x -{-# INLINE find #-} -replicate x = T.replicate i x -{-# INLINE replicate #-} -index x = x `T.index` i -{-# INLINE index #-} diff --git a/tests/Tests/Inspection/Strict.hs b/tests/Tests/Inspection/Strict.hs deleted file mode 100644 index d6dcc175..00000000 --- a/tests/Tests/Inspection/Strict.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -O -fno-warn-unused-top-binds -fno-warn-missing-signatures -fno-warn-name-shadowing -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-} - -module Tests.Inspection.Strict (tests) where - -import Prelude hiding (all, any, drop, dropWhile, filter, foldl, foldl1, foldr, foldr1, head, init, iterate, last, length, map, maximum, minimum, null, reverse, scanl, scanl1, scanr, scanr1, tail, take, takeWhile) -import Data.Char (isAscii) - -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - -import Test.Tasty -import Test.Tasty.Inspection - -all_cons_pack = all . cons . T.pack -all_drop_pack = all . drop . T.pack -all_dropWhileEnd_singleton = all . dropWhileEnd . T.singleton -all_justifyRight_singleton = all . justifyRight . T.singleton -all_scanl_init_unfoldrN = all . scanl . T.init . unfoldrN -all_stripEnd_stripStart_singleton = all . T.stripEnd . T.stripStart . T.singleton -any_filter_init_pack = any . filter . T.init . T.pack -any_justifyRight_dropEnd_singleton = any . justifyRight . dropEnd . T.singleton -any_singleton = any . T.singleton -any_stripStart_singleton = any . T.stripStart . T.singleton -any_toCaseFold_unfoldr = any . T.toCaseFold . unfoldr -any_unfoldrN = any . unfoldrN -compareLength_cons_snoc_singleton = compareLength . cons . snoc . T.singleton -compareLength_drop_unfoldr = compareLength . drop . unfoldr -compareLength_empty = compareLength . empty -compareLength_pack = compareLength . T.pack -compareLength_singleton = compareLength . T.singleton -compareLength_snoc_unfoldr = compareLength . snoc . unfoldr -compareLength_takeWhile_intersperse_unfoldr = compareLength . takeWhile . intersperse . unfoldr -compareLength_toTitle_singleton = compareLength . T.toTitle . T.singleton -compareLength_toTitle_unfoldrN = compareLength . T.toTitle . unfoldrN -compareLength_unfoldr = compareLength . unfoldr -find_decodeUtf8 = find . T.decodeUtf8 -find_take_unfoldrN = find . take . unfoldrN -foldl'_cons_pack = foldl' . cons . T.pack -foldl'_scanr1_singleton = foldl' . scanr1 . T.singleton -foldl'_toCaseFold_intersperse_unfoldrN = foldl' . T.toCaseFold . intersperse . unfoldrN -foldl_center_empty = foldl . center . empty -foldl_justifyLeft_cons_empty = foldl . justifyLeft . cons . empty -foldl_justifyLeft_decodeUtf8 = foldl . justifyLeft . T.decodeUtf8 -foldl_pack = foldl . T.pack -foldl_scanl_dropWhile_empty = foldl . scanl . dropWhile . empty -foldl1'_append_append_decodeUtf8 = foldl1' . append . append . T.decodeUtf8 -foldl1'_dropWhile_dropWhileEnd_singleton = foldl1' . dropWhile . dropWhileEnd . T.singleton -foldl1'_scanl_decodeUtf8 = foldl1' . scanl . T.decodeUtf8 -foldl1'_scanl_justifyLeft_unfoldr = foldl1' . scanl . justifyLeft . unfoldr -foldl1'_singleton = foldl1' . T.singleton -foldl1'_take_unfoldr = foldl1' . take . unfoldr -foldl1_intersperse_empty = foldl1 . intersperse . empty -foldl1_scanr_singleton = foldl1 . scanr . T.singleton -foldl1_tail_singleton = foldl1 . T.tail . T.singleton -foldr_append_singleton = foldr . append . T.singleton -foldr_empty = foldr . empty -foldr_intersperse_dropWhile_unfoldr = foldr . intersperse . dropWhile . unfoldr -foldr_intersperse_singleton = foldr . intersperse . T.singleton -foldr_scanl_unfoldr = foldr . scanl . unfoldr -foldr1_dropWhile_intersperse_pack = foldr1 . dropWhile . intersperse . T.pack -foldr1_justifyLeft_scanl1_empty = foldr1 . justifyLeft . scanl1 . empty -foldr1_reverse_unfoldrN = foldr1 . T.reverse . unfoldrN -foldr1_singleton = foldr1 . T.singleton -foldr1_take_drop_pack = foldr1 . take . drop . T.pack -foldr1_unfoldrN = foldr1 . unfoldrN -head_append_toTitle_singleton = T.head . append . T.toTitle . T.singleton -head_cons_unfoldr = T.head . cons . unfoldr -head_drop_decodeUtf8 = T.head . drop . T.decodeUtf8 -head_singleton = T.head . T.singleton -head_strip_take_empty = T.head . T.strip . take . empty -head_takeEnd_take_singleton = T.head . takeEnd . take . T.singleton -index_dropWhile_unfoldr = index . dropWhile . unfoldr -index_dropWhileEnd_empty = index . dropWhileEnd . empty -index_justifyLeft_stripEnd_singleton = index . justifyLeft . T.stripEnd . T.singleton -isPrefixOf_dropWhile_dropWhile_pack = isPrefixOf . dropWhile . dropWhile . T.pack -isPrefixOf_init_take_unfoldrN = isPrefixOf . T.init . take . unfoldrN -isPrefixOf_snoc_stripStart_pack = isPrefixOf . snoc . T.stripStart . T.pack -isPrefixOf_take_empty = isPrefixOf . take . empty -isPrefixOf_take_singleton = isPrefixOf . take . T.singleton -last_dropWhile_unfoldrN = T.last . dropWhile . unfoldrN -last_map_take_pack = T.last . map . take . T.pack -last_tail_unfoldrN = T.last . T.tail . unfoldrN -last_toUpper_stripStart_singleton = T.last . T.toUpper . T.stripStart . T.singleton -last_toUpper_toLower_unfoldrN = T.last . T.toUpper . T.toLower . unfoldrN -length_empty = T.length . empty -length_intersperse_center_singleton = T.length . intersperse . center . T.singleton -length_justifyLeft_decodeUtf8 = T.length . justifyLeft . T.decodeUtf8 -length_pack = T.length . T.pack -length_reverse_singleton = T.length . T.reverse . T.singleton -length_takeWhile_intersperse_singleton = T.length . takeWhile . intersperse . T.singleton -length_takeWhile_singleton = T.length . takeWhile . T.singleton -length_toTitle_empty = T.length . T.toTitle . empty -maximum_justifyLeft_filter_singleton = T.maximum . justifyLeft . filter . T.singleton -maximum_justifyRight_singleton = T.maximum . justifyRight . T.singleton -maximum_take_unfoldrN = T.maximum . take . unfoldrN -maximum_toLower_empty = T.maximum . T.toLower . empty -minimum_init_singleton = T.minimum . T.init . T.singleton -minimum_intersperse_toTitle_singleton = T.minimum . intersperse . T.toTitle . T.singleton -minimum_map_singleton = T.minimum . map . T.singleton -minimum_scanl1_takeWhile_singleton = T.minimum . scanl1 . takeWhile . T.singleton -minimum_tail_map_singleton = T.minimum . T.tail . map . T.singleton -minimum_unfoldrN = T.minimum . unfoldrN -null_cons_singleton = T.null . cons . T.singleton -null_init_drop_decodeUtf8 = T.null . T.init . drop . T.decodeUtf8 -null_map_empty = T.null . map . empty -null_toCaseFold_dropAround_singleton = T.null . T.toCaseFold . dropAround . T.singleton -unpack_empty = T.unpack . empty -unpack_justifyLeft_take_empty = T.unpack . justifyLeft . take . empty -unpack_map_pack = T.unpack . map . T.pack -unpack_stripEnd_takeWhileEnd_singleton = T.unpack . T.stripEnd . takeWhileEnd . T.singleton -unpack_toCaseFold_scanr_singleton = T.unpack . T.toCaseFold . scanr . T.singleton -unpack_toUpper_snoc_singleton = T.unpack . T.toUpper . snoc . T.singleton -unpack_unfoldr = T.unpack . unfoldr - -tests :: TestTree -tests = testGroup "Strict fusion" [$(inspectNames (`hasNoType` ''T.Text) - [ -#if __GLASGOW_HASKELL__ >= 806 - 'all_cons_pack, 'all_drop_pack, 'all_scanl_init_unfoldrN, 'any_filter_init_pack, 'any_toCaseFold_unfoldr, 'any_unfoldrN, 'compareLength_drop_unfoldr, 'compareLength_empty, 'compareLength_pack, 'compareLength_snoc_unfoldr, 'compareLength_takeWhile_intersperse_unfoldr, 'compareLength_toTitle_unfoldrN, 'compareLength_unfoldr, 'find_decodeUtf8, 'find_take_unfoldrN, 'foldl'_cons_pack, 'foldl'_toCaseFold_intersperse_unfoldrN, 'foldl_justifyLeft_cons_empty, 'foldl_justifyLeft_decodeUtf8, 'foldl_pack, 'foldl_scanl_dropWhile_empty, 'foldl1'_append_append_decodeUtf8, 'foldl1'_scanl_decodeUtf8, 'foldl1'_scanl_justifyLeft_unfoldr, 'foldl1'_take_unfoldr, 'foldl1_intersperse_empty, 'foldr_empty, 'foldr_intersperse_dropWhile_unfoldr, 'foldr_scanl_unfoldr, 'foldr1_dropWhile_intersperse_pack, 'foldr1_justifyLeft_scanl1_empty, 'foldr1_reverse_unfoldrN, 'foldr1_take_drop_pack, 'foldr1_unfoldrN, 'head_cons_unfoldr, 'head_drop_decodeUtf8, 'head_strip_take_empty, 'index_dropWhile_unfoldr, 'index_dropWhileEnd_empty, 'isPrefixOf_dropWhile_dropWhile_pack, 'isPrefixOf_init_take_unfoldrN, 'isPrefixOf_snoc_stripStart_pack, 'isPrefixOf_take_empty, 'last_dropWhile_unfoldrN, 'last_map_take_pack, 'last_tail_unfoldrN, 'last_toUpper_toLower_unfoldrN, 'length_empty, 'length_justifyLeft_decodeUtf8, 'length_pack, 'length_toTitle_empty, 'maximum_take_unfoldrN, 'maximum_toLower_empty, 'minimum_unfoldrN, 'null_init_drop_decodeUtf8, 'null_map_empty, 'unpack_empty, 'unpack_justifyLeft_take_empty, 'unpack_map_pack, 'unpack_unfoldr -#endif --- https://gitlab.haskell.org/ghc/ghc/-/issues/19822 -#if __GLASGOW_HASKELL__ >= 806 && __GLASGOW_HASKELL__ < 900 - , 'foldl_center_empty -- the only non-singleton-related regression - , 'all_dropWhileEnd_singleton, 'all_justifyRight_singleton, 'all_stripEnd_stripStart_singleton, 'any_justifyRight_dropEnd_singleton, 'any_singleton, 'any_stripStart_singleton, 'compareLength_cons_snoc_singleton, 'compareLength_singleton, 'compareLength_toTitle_singleton, 'foldl'_scanr1_singleton, 'foldl1'_dropWhile_dropWhileEnd_singleton, 'foldl1_scanr_singleton, 'foldl1_tail_singleton, 'foldr_append_singleton, 'foldl1'_singleton, 'foldr_intersperse_singleton, 'foldr1_singleton, 'head_append_toTitle_singleton, 'head_singleton, 'head_takeEnd_take_singleton, 'isPrefixOf_take_singleton, 'index_justifyLeft_stripEnd_singleton, 'last_toUpper_stripStart_singleton, 'length_intersperse_center_singleton, 'length_reverse_singleton, 'length_takeWhile_intersperse_singleton, 'length_takeWhile_singleton, 'maximum_justifyLeft_filter_singleton, 'maximum_justifyRight_singleton, 'minimum_init_singleton, 'minimum_intersperse_toTitle_singleton, 'minimum_map_singleton, 'minimum_scanl1_takeWhile_singleton, 'minimum_tail_map_singleton, 'null_cons_singleton, 'null_toCaseFold_dropAround_singleton, 'unpack_stripEnd_takeWhileEnd_singleton, 'unpack_toCaseFold_scanr_singleton, 'unpack_toUpper_snoc_singleton -#endif - ])] - ---------------------------------------------------------------------------------- --- Definitions below are from inspection-testing package by Joachim Breitner. --- - -i = 42 -{-# NOINLINE i #-} - -empty _ = T.empty -{-# INLINE empty #-} -take x = T.take i x -{-# INLINE take #-} -takeEnd x = T.takeEnd i x -{-# INLINE takeEnd #-} -drop x = T.drop i x -{-# INLINE drop #-} -dropEnd x = T.dropEnd i x -{-# INLINE dropEnd #-} -cons x = 'x' `T.cons` x -{-# INLINE cons #-} -snoc x = x `T.snoc` 'x' -{-# INLINE snoc #-} -map x = T.map succ x -{-# INLINE map #-} -justifyLeft x = T.justifyLeft 42 'x' x -{-# INLINE justifyLeft #-} -justifyRight x = T.justifyRight 42 'x' x -{-# INLINE justifyRight #-} -center x = T.center i 'x' x -{-# INLINE center #-} -intersperse x = T.intersperse 'x' x -{-# INLINE intersperse #-} -append x = unfoldrN 'y' `T.append` x -{-# INLINE append #-} -isPrefixOf x = unfoldrN 'a' `T.isPrefixOf` x -{-# INLINE isPrefixOf #-} -compareLength x = x `T.compareLength` i -{-# INLINE compareLength #-} -foldl x = T.foldl (\x c -> x + fromEnum c) 0 x -{-# INLINE foldl #-} -foldl' x = T.foldl' (\x c -> x + fromEnum c) 0 x -{-# INLINE foldl' #-} -foldl1 x = T.foldl1 (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x -{-# INLINE foldl1 #-} -foldl1' x = T.foldl1' (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x -{-# INLINE foldl1' #-} -foldr x = T.foldr (\c x -> x + fromEnum c) 0 x -{-# INLINE foldr #-} -foldr1 x = T.foldr1 (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x -{-# INLINE foldr1 #-} -any x = T.any isAscii x -{-# INLINE any #-} -all x = T.all isAscii x -{-# INLINE all #-} -scanl x = T.scanl (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) 'x' x -{-# INLINE scanl #-} -scanl1 x = T.scanl1 (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x -{-# INLINE scanl1 #-} -scanr x = T.scanr (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) 'x' x -{-# INLINE scanr #-} -scanr1 x = T.scanr1 (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x -{-# INLINE scanr1 #-} -unfoldr x = T.unfoldr (\c -> if c == 'z' then Nothing else Just (c, succ c)) x -{-# INLINE unfoldr #-} -unfoldrN x = T.unfoldrN i (\c -> if c == 'z' then Nothing else Just (c, succ c)) x -{-# INLINE unfoldrN #-} -takeWhile x = T.takeWhile isAscii x -{-# INLINE takeWhile #-} -dropWhile x = T.dropWhile isAscii x -{-# INLINE dropWhile #-} -takeWhileEnd x = T.takeWhileEnd isAscii x -{-# INLINE takeWhileEnd #-} -dropWhileEnd x = T.dropWhileEnd isAscii x -{-# INLINE dropWhileEnd #-} -dropAround x = T.dropAround isAscii x -{-# INLINE dropAround #-} -filter x = T.filter isAscii x -{-# INLINE filter #-} -find x = T.find isAscii x -{-# INLINE find #-} -index x = x `T.index` i -{-# INLINE index #-} diff --git a/text.cabal b/text.cabal index 4bee25a2..b9dd963e 100644 --- a/text.cabal +++ b/text.cabal @@ -197,15 +197,6 @@ test-suite tests Tests.SlowFunctions Tests.Utils - -- Fusion tests fail in developer mode (because asserts break inlining) - -- and take ages to build. - if flag(developer) - cpp-options: -DASSERTS - else - other-modules: - Tests.Inspection.Lazy - Tests.Inspection.Strict - build-depends: QuickCheck >= 2.14.1 && < 2.15, base <5, @@ -215,7 +206,6 @@ test-suite tests random, tasty, tasty-hunit, - tasty-inspection-testing, tasty-quickcheck, template-haskell, text From 409f62f38aea93b96f08ce0fb4a84557c796bc6a Mon Sep 17 00:00:00 2001 From: Bodigrim Date: Wed, 16 Jun 2021 21:14:59 +0100 Subject: [PATCH 2/2] Briefly mention changes in changelog.md --- changelog.md | 4 ++++ src/Data/Text.hs | 11 +++++++++++ src/Data/Text/Lazy.hs | 11 +++++++++++ 3 files changed, 26 insertions(+) diff --git a/changelog.md b/changelog.md index e5f49fae..3c1d32bd 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +### 1.3 + +* Disable implicit fusion rules + ### 1.2.4.2 * Support GHC-9.2 diff --git a/src/Data/Text.hs b/src/Data/Text.hs index c95f66bf..717f8703 100644 --- a/src/Data/Text.hs +++ b/src/Data/Text.hs @@ -43,6 +43,9 @@ module Data.Text -- * Definition of character -- $character_definition + -- * Fusion + -- $fusion + -- * Types Text @@ -308,6 +311,14 @@ import Text.Printf (PrintfArg, formatArg, formatString) -- measure. For details, see -- .) +-- $fusion +-- +-- Starting from @text-1.3@ fusion is no longer implicit, +-- and pipelines of transormations usually allocate intermediate 'Text' values. +-- Users, who observe significant changes to performances, +-- are encouraged to use fusion framework explicitly, employing +-- "Data.Text.Internal.Fusion" and "Data.Text.Internal.Fusion.Common". + instance Eq Text where Text arrA offA lenA == Text arrB offB lenB | lenA == lenB = A.equal arrA offA arrB offB lenA diff --git a/src/Data/Text/Lazy.hs b/src/Data/Text/Lazy.hs index 5e333f59..f47631f0 100644 --- a/src/Data/Text/Lazy.hs +++ b/src/Data/Text/Lazy.hs @@ -37,6 +37,9 @@ module Data.Text.Lazy ( + -- * Fusion + -- $fusion + -- * Acceptable data -- $replacement @@ -233,6 +236,14 @@ import Text.Printf (PrintfArg, formatArg, formatString) import GHC.Stack (HasCallStack) #endif +-- $fusion +-- +-- Starting from @text-1.3@ fusion is no longer implicit, +-- and pipelines of transormations usually allocate intermediate 'Text' values. +-- Users, who observe significant changes to performances, +-- are encouraged to use fusion framework explicitly, employing +-- "Data.Text.Internal.Fusion" and "Data.Text.Internal.Fusion.Common". + -- $replacement -- -- A 'Text' value is a sequence of Unicode scalar values, as defined