548ca22 · text · git.iko.soy

git.iko.soy/text

Merge pull request #200

Fix usage of size hints which resulted in serious bugs such as operations like `(== 1) . length . filter (== ',')` (see #197) giving wrong results.

commit548ca22e476560c3e7c9c6af88eac49c586a1acc authorHerbert Valerio Riedel <hvr@gnu.org> dateSun 17 Dec 2017, 00:03 (9 years ago) parentccbfabe cfb8278

6 files changed+91−33

compare with master

unifiedsplit

Data/Text.hs+15 Data/Text/Internal/Fusion/Common.hs+28−22 Data/Text/Internal/Fusion/Size.hs+32−6 Data/Text/Internal/Fusion/Types.hs+4−4 tests/Tests/Regressions.hs+11 text.cabal+1−1

Data/Text.hs+15

@@ -34,6 +34,7 @@

3434-- with Unicode text (including normalization, regular expressions,

3535-- non-standard encodings, text breaking, and locales), see

3636-- <http://hackage.haskell.org/package/text-icu the text-icu package >.

37+--

3738

3839module Data.Text

3940 (

@@ -43,6 +44,9 @@ module Data.Text

4344 -- * Acceptable data

4445 -- $replacement

4546

47+ -- * Definition of character

48+ -- $character_definition

49+

4650 -- * Fusion

4751 -- $fusion

4852

@@ -247,6 +251,17 @@ import qualified GHC.Exts as Exts

247251import Text.Printf (PrintfArg, formatArg, formatString)

248252#endif

249253

254+-- $character-definition

255+--

256+-- This package uses the word /character/ to denote Unicode code points.

257+--

258+-- Note that this is not the same thing as a grapheme (e.g. a composition of

259+-- code points that form one visual symbol). For instance, consider the grapheme

260+-- @ä@. This symbol has two Unicode representations: a single code-point

261+-- representation @U+00E4@ (the @LATIN SMALL LETTER A WITH DIAERESIS@ code

262+-- point), and a two code point representation @U+0061@ (the @A@ code point) and

263+-- @U+0308@ (the @COMBINING DIAERESIS@ code point).

264+

250265-- $strict

251266--

252267-- This package provides both strict and lazy 'Text' types. The

Data/Text/Internal/Fusion/Common.hs+28−22

@@ -1,4 +1,4 @@

1−{-# LANGUAGE BangPatterns, MagicHash, Rank2Types #-}

1+{-# LANGUAGE PatternGuards, BangPatterns, MagicHash, Rank2Types #-}

22-- |

33-- Module : Data.Text.Internal.Fusion.Common

44-- Copyright : (c) Bryan O'Sullivan 2009, 2012

@@ -117,7 +117,7 @@ import GHC.Prim (Addr#, chr#, indexCharOffAddr#, ord#)

117117import GHC.Types (Char(..), Int(..))

118118

119119singleton :: Char -> Stream Char

120−singleton c = Stream next False 1

120+singleton c = Stream next False (codePointsSize 1)

121121 where next False = Yield c True

122122 next True = Done

123123{-# INLINE [0] singleton #-}

@@ -175,7 +175,7 @@ data C s = C0 !s

175175

176176-- | /O(n)/ Adds a character to the front of a Stream Char.

177177cons :: Char -> Stream Char -> Stream Char

178−cons !w (Stream next0 s0 len) = Stream next (C1 s0) (len+1)

178+cons !w (Stream next0 s0 len) = Stream next (C1 s0) (len + codePointsSize 1)

179179 where

180180 next (C1 s) = Yield w (C0 s)

181181 next (C0 s) = case next0 s of

@@ -189,7 +189,7 @@ data Snoc a = N

189189

190190-- | /O(n)/ Adds a character to the end of a stream.

191191snoc :: Stream Char -> Char -> Stream Char

192−snoc (Stream next0 xs0 len) w = Stream next (J xs0) (len+1)

192+snoc (Stream next0 xs0 len) w = Stream next (J xs0) (len + codePointsSize 1)

193193 where

194194 next (J xs) = case next0 xs of

195195 Done -> Yield w N

@@ -237,7 +237,7 @@ uncons :: Stream Char -> Maybe (Char, Stream Char)

237237uncons (Stream next s0 len) = loop_uncons s0

238238 where

239239 loop_uncons !s = case next s of

240− Yield x s1 -> Just (x, Stream next s1 (len-1))

240+ Yield x s1 -> Just (x, Stream next s1 (len - codePointsSize 1))

241241 Skip s' -> loop_uncons s'

242242 Done -> Nothing

243243{-# INLINE [0] uncons #-}

@@ -260,7 +260,7 @@ last (Stream next s0 _len) = loop0_last s0

260260-- | /O(1)/ Returns all characters after the head of a Stream Char, which must

261261-- be non-empty.

262262tail :: Stream Char -> Stream Char

263−tail (Stream next0 s0 len) = Stream next (C0 s0) (len-1)

263+tail (Stream next0 s0 len) = Stream next (C0 s0) (len - codePointsSize 1)

264264 where

265265 next (C0 s) = case next0 s of

266266 Done -> emptyError "tail"

@@ -278,7 +278,7 @@ data Init s = Init0 !s

278278-- | /O(1)/ Returns all but the last character of a Stream Char, which

279279-- must be non-empty.

280280init :: Stream Char -> Stream Char

281−init (Stream next0 s0 len) = Stream next (Init0 s0) (len-1)

281+init (Stream next0 s0 len) = Stream next (Init0 s0) (len - codePointsSize 1)

282282 where

283283 next (Init0 s) = case next0 s of

284284 Done -> emptyError "init"

@@ -318,11 +318,14 @@ lengthI (Stream next s0 _len) = loop_length 0 s0

318318-- greater than the number or if the stream can't possibly be as long

319319-- as the number supplied, and hence be more efficient.

320320compareLengthI :: Integral a => Stream Char -> a -> Ordering

321−compareLengthI (Stream next s0 len) n =

322− case compareSize len (fromIntegral n) of

323− Just o -> o

324− Nothing -> loop_cmp 0 s0

321+compareLengthI (Stream next s0 len) n

322+ -- Note that @len@ tracks code units whereas we want to compare the length

323+ -- in code points. Specifically, a stream with hint @len@ may consist of

324+ -- anywhere from @len/2@ to @len@ code points.

325+ | Just r <- compareSize len n' = r

326+ | otherwise = loop_cmp 0 s0

325327 where

328+ n' = codePointsSize $ fromIntegral n

326329 loop_cmp !z s = case next s of

327330 Done -> compare z n

328331 Skip s' -> loop_cmp z s'

@@ -368,7 +371,7 @@ data I s = I1 !s

368371-- | /O(n)/ Take a character and place it between each of the

369372-- characters of a 'Stream Char'.

370373intersperse :: Char -> Stream Char -> Stream Char

371−intersperse c (Stream next0 s0 len) = Stream next (I1 s0) len

374+intersperse c (Stream next0 s0 len) = Stream next (I1 s0) (len + unknownSize)

372375 where

373376 next (I1 s) = case next0 s of

374377 Done -> Done

@@ -393,9 +396,11 @@ intersperse c (Stream next0 s0 len) = Stream next (I1 s0) len

393396-- functions may map one input character to two or three output

394397-- characters.

395398

399+-- | Map a 'Stream' through the given case-mapping function.

396400caseConvert :: (forall s. Char -> s -> Step (CC s) Char)

397401 -> Stream Char -> Stream Char

398−caseConvert remap (Stream next0 s0 len) = Stream next (CC s0 '\0' '\0') len

402+caseConvert remap (Stream next0 s0 len) =

403+ Stream next (CC s0 '\0' '\0') (len `unionSize` 3*len)

399404 where

400405 next (CC s '\0' _) =

401406 case next0 s of

@@ -458,7 +463,7 @@ toLower = caseConvert lowerMapping

458463-- Fox\" is correctly title cased—but this function will

459464-- capitalize /every/ word.

460465toTitle :: Stream Char -> Stream Char

461−toTitle (Stream next0 s0 len) = Stream next (CC (False :*: s0) '\0' '\0') len

466+toTitle (Stream next0 s0 len) = Stream next (CC (False :*: s0) '\0' '\0') (len + unknownSize)

462467 where

463468 next (CC (letter :*: s) '\0' _) =

464469 case next0 s of

@@ -479,7 +484,7 @@ data Justify i s = Just1 !i !s

479484

480485justifyLeftI :: Integral a => a -> Char -> Stream Char -> Stream Char

481486justifyLeftI k c (Stream next0 s0 len) =

482− Stream next (Just1 0 s0) (larger (fromIntegral k) len)

487+ Stream next (Just1 0 s0) (larger (fromIntegral k * charSize c + len) len)

483488 where

484489 next (Just1 n s) =

485490 case next0 s of

@@ -699,7 +704,7 @@ replicateI n (Stream next0 s0 len) =

699704-- (a,b), in which case, a is the next Char in the string, and b is

700705-- the seed value for further production.

701706unfoldr :: (a -> Maybe (Char,a)) -> a -> Stream Char

702−unfoldr f s0 = Stream next s0 1 -- HINT maybe too low

707+unfoldr f s0 = Stream next s0 unknownSize

703708 where

704709 {-# INLINE next #-}

705710 next !s = case f s of

@@ -713,7 +718,7 @@ unfoldr f s0 = Stream next s0 1 -- HINT maybe too low

713718-- 'unfoldr' when the length of the result is known.

714719unfoldrNI :: Integral a => a -> (b -> Maybe (Char,b)) -> b -> Stream Char

715720unfoldrNI n f s0 | n < 0 = empty

716− | otherwise = Stream next (0 :*: s0) (fromIntegral (n*2)) -- HINT maybe too high

721+ | otherwise = Stream next (0 :*: s0) (maxSize $ fromIntegral (n*2))

717722 where

718723 {-# INLINE next #-}

719724 next (z :*: s) = case f s of

@@ -730,7 +735,7 @@ unfoldrNI n f s0 | n < 0 = empty

730735-- length of the stream.

731736take :: Integral a => a -> Stream Char -> Stream Char

732737take n0 (Stream next0 s0 len) =

733− Stream next (n0 :*: s0) (smaller len (fromIntegral (max 0 n0)))

738+ Stream next (n0 :*: s0) (smaller len (codePointsSize $ fromIntegral n0))

734739 where

735740 {-# INLINE next #-}

736741 next (n :*: s) | n <= 0 = Done

@@ -748,7 +753,7 @@ data Drop a s = NS !s

748753-- is greater than the length of the stream.

749754drop :: Integral a => a -> Stream Char -> Stream Char

750755drop n0 (Stream next0 s0 len) =

751− Stream next (JS n0 s0) (len - fromIntegral (max 0 n0))

756+ Stream next (JS n0 s0) (len - codePointsSize (fromIntegral n0))

752757 where

753758 {-# INLINE next #-}

754759 next (JS n s)

@@ -766,7 +771,7 @@ drop n0 (Stream next0 s0 len) =

766771-- | 'takeWhile', applied to a predicate @p@ and a stream, returns the

767772-- longest prefix (possibly empty) of elements that satisfy @p@.

768773takeWhile :: (Char -> Bool) -> Stream Char -> Stream Char

769−takeWhile p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high

774+takeWhile p (Stream next0 s0 len) = Stream next s0 (len - unknownSize)

770775 where

771776 {-# INLINE next #-}

772777 next !s = case next0 s of

@@ -778,7 +783,7 @@ takeWhile p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high

778783

779784-- | @'dropWhile' p xs@ returns the suffix remaining after @'takeWhile' p xs@.

780785dropWhile :: (Char -> Bool) -> Stream Char -> Stream Char

781−dropWhile p (Stream next0 s0 len) = Stream next (L s0) len -- HINT maybe too high

786+dropWhile p (Stream next0 s0 len) = Stream next (L s0) (len - unknownSize)

782787 where

783788 {-# INLINE next #-}

784789 next (L s) = case next0 s of

@@ -857,7 +862,8 @@ indexI (Stream next s0 _len) n0

857862-- returns a stream containing those characters that satisfy the

858863-- predicate.

859864filter :: (Char -> Bool) -> Stream Char -> Stream Char

860−filter p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high

865+filter p (Stream next0 s0 len) =

866+ Stream next s0 (len - unknownSize) -- HINT maybe too high

861867 where

862868 next !s = case next0 s of

863869 Done -> Done

Data/Text/Internal/Fusion/Size.hs+32−6

@@ -19,11 +19,16 @@

1919module Data.Text.Internal.Fusion.Size

2020 (

2121 Size

22− , exactly

22+ -- * Sizes

2323 , exactSize

2424 , maxSize

2525 , betweenSize

2626 , unknownSize

27+ , unionSize

28+ , charSize

29+ , codePointsSize

30+ -- * Querying sizes

31+ , exactly

2732 , smaller

2833 , larger

2934 , upperBound

@@ -32,11 +37,13 @@ module Data.Text.Internal.Fusion.Size

3237 , isEmpty

3338 ) where

3439

40+import Data.Char (ord)

3541import Data.Text.Internal (mul)

3642#if defined(ASSERTS)

3743import Control.Exception (assert)

3844#endif

3945

46+-- | A size in UTF-16 code units.

4047data Size = Between {-# UNPACK #-} !Int {-# UNPACK #-} !Int -- ^ Lower and upper bounds on size.

4148 | Unknown -- ^ Unknown size.

4249 deriving (Eq, Show)

@@ -46,6 +53,17 @@ exactly (Between na nb) | na == nb = Just na

4653exactly _ = Nothing

4754{-# INLINE exactly #-}

4855

56+-- | The 'Size' of the given code point.

57+charSize :: Char -> Size

58+charSize c

59+ | ord c < 0x10000 = exactSize 1

60+ | otherwise = exactSize 2

61+

62+-- | The 'Size' of @n@ code points.

63+codePointsSize :: Int -> Size

64+codePointsSize n = Between n (2*n)

65+{-# INLINE codePointsSize #-}

66+

4967exactSize :: Int -> Size

5068exactSize n =

5169#if defined(ASSERTS)

@@ -71,6 +89,10 @@ betweenSize m n =

7189 Between m n

7290{-# INLINE betweenSize #-}

7391

92+unionSize :: Size -> Size -> Size

93+unionSize (Between a b) (Between c d) = Between (min a c) (max b d)

94+unionSize _ _ = Unknown

95+

7496unknownSize :: Size

7597unknownSize = Unknown

7698{-# INLINE unknownSize #-}

@@ -140,11 +162,15 @@ lowerBound _ (Between n _) = n

140162lowerBound k _ = k

141163{-# INLINE lowerBound #-}

142164

143−compareSize :: Size -> Int -> Maybe Ordering

144−compareSize (Between ma mb) n

145− | mb < n = Just LT

146− | ma > n = Just GT

147− | ma == n && mb == n = Just EQ

165+-- | Determine the ordering relationship between two 'Size's, or 'Nothing' in

166+-- the indeterminate case.

167+compareSize :: Size -> Size -> Maybe Ordering

168+compareSize (Between ma mb) (Between na nb)

169+ | mb < na = Just LT

170+ | ma > nb = Just GT

171+ | ma == mb

172+ , ma == na

173+ , ma == nb = Just EQ

148174compareSize _ _ = Nothing

149175

150176

Data/Text/Internal/Fusion/Types.hs+4−4

@@ -75,16 +75,16 @@ instance (Ord a) => Ord (Stream a) where

7575-- unstreaming functions must be able to cope with the hint being too

7676-- small or too large.

7777--

78−-- The size hint tries to track the UTF-16 code points in a stream,

79−-- but often counts the number of characters instead. It can easily

78+-- The size hint tries to track the UTF-16 code units in a stream,

79+-- but often counts the number of code points instead. It can easily

8080-- undercount if, for instance, a transformed stream contains astral

81−-- plane characters (those above 0x10000).

81+-- plane code points (those above 0x10000).

8282

8383data Stream a =

8484 forall s. Stream

8585 (s -> Step s a) -- stepper function

8686 !s -- current state

87− !Size -- size hint

87+ !Size -- size hint in code units

8888

8989-- | /O(n)/ Determines if two streams are equal.

9090eq :: (Eq a) => Stream a -> Stream a -> Bool

tests/Tests/Regressions.hs+11

@@ -72,6 +72,16 @@ mapAccumL_resize = do

7272 assertEqual "mapAccumL should correctly size buffers for two-word results"

7373 (count * 2) (T.lengthWord16 (snd val))

7474

75+-- See GitHub #197

76+t197 :: IO ()

77+t197 =

78+ assertBool "length (filter (==',') \"0,00\") should be 1" (currencyParser "0,00")

79+ where

80+ currencyParser x = cond == 1

81+ where

82+ cond = length fltr

83+ fltr = filter (== ',') x

84+

7585tests :: F.Test

7686tests = F.testGroup "Regressions"

7787 [ F.testCase "hGetContents_crash" hGetContents_crash

@@ -79,4 +89,5 @@ tests = F.testGroup "Regressions"

7989 , F.testCase "mapAccumL_resize" mapAccumL_resize

8090 , F.testCase "replicate_crash" replicate_crash

8191 , F.testCase "utf8_decode_unsafe" utf8_decode_unsafe

92+ , F.testCase "t197" t197

8293 ]

text.cabal+1−1

@@ -168,7 +168,7 @@ test-suite tests

168168 include-dirs: include

169169

170170 ghc-options:

171− -Wall -threaded -O0 -rtsopts

171+ -Wall -threaded -O1 -rtsopts

172172

173173 cpp-options:

174174 -DASSERTS -DHAVE_DEEPSEQ -DTEST_SUITE