text 0.7.2.1 → 0.8.0.0

raw patch · 31 files changed

+1688/−755 lines, 31 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Text.hs +153/−52
• Data/Text/Array.hs +175/−214
• Data/Text/Encoding/Fusion.hs +9/−4
• Data/Text/Encoding/Fusion/Common.hs +1/−1
• Data/Text/Encoding/Utf16.hs +4/−4
• Data/Text/Encoding/Utf32.hs +5/−5
• Data/Text/Encoding/Utf8.hs +24/−10
• Data/Text/Foreign.hs +52/−8
• Data/Text/Fusion.hs +25/−22
• Data/Text/Fusion/Common.hs +26/−6
• Data/Text/Fusion/Internal.hs +3/−4
• Data/Text/Fusion/Size.hs +19/−2
• Data/Text/IO.hs +93/−33
• Data/Text/IO/Internal.hs +7/−7
• Data/Text/Internal.hs +19/−16
• Data/Text/Lazy.hs +118/−25
• Data/Text/Lazy/Builder.hs +27/−51
• Data/Text/Lazy/Encoding.hs +87/−16
• Data/Text/Lazy/Encoding/Fusion.hs +189/−12
• Data/Text/Lazy/Fusion.hs +13/−11
• Data/Text/Lazy/IO.hs +17/−6
• Data/Text/Lazy/Internal.hs +34/−23
• Data/Text/Lazy/Search.hs +16/−11
• Data/Text/Search.hs +5/−2
• Data/Text/Unsafe.hs +40/−24
• Data/Text/UnsafeChar.hs +26/−14
• tests/Benchmarks.hs +8/−1
• tests/Makefile +33/−17
• tests/Properties.hs +387/−131
• tests/QuickCheckUtils.hs +68/−19
• text.cabal +5/−4

@@ -3,9 +3,9 @@  -- | -- Module      : Data.Text--- Copyright   : (c) Tom Harper 2008-2009,---               (c) Bryan O'Sullivan 2009,---               (c) Duncan Coutts 2009+-- Copyright   : (c) 2008, 2009 Tom Harper,+--               (c) 2009, 2010 Bryan O'Sullivan,+--               (c) 2009 Duncan Coutts -- -- License     : BSD-style -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,@@ -47,6 +47,7 @@     , init     , null     , length+    , compareLength      -- * Transformations     , map@@ -140,6 +141,10 @@     , isSuffixOf     , isInfixOf +    -- ** View patterns+    , prefixed+    , suffixed+     -- * Searching     , filter     , find@@ -163,14 +168,16 @@     ) where  import Prelude (Char, Bool(..), Functor(..), Int, Maybe(..), String,-                Eq(..), Ord(..), (++),+                Eq(..), Ord(..), Ordering(..), (++),                 Read(..), Show(..),-                (&&), (||), (+), (-), (.), ($), (>>), (*),+                (&&), (||), (+), (-), (.), ($), ($!), (>>), (*),                 div, error, not, return, otherwise) #if defined(HAVE_DEEPSEQ) import Control.DeepSeq (NFData) #endif+#if defined(ASSERTS) import Control.Exception (assert)+#endif import Data.Char (isSpace) import Data.Data (Data(gfoldl, toConstr, gunfold, dataTypeOf)) #if __GLASGOW_HASKELL__ >= 612@@ -179,18 +186,17 @@ import Data.Data (mkNorepType) #endif import Control.Monad (foldM)-import Control.Monad.ST (ST) import qualified Data.Text.Array as A import qualified Data.List as L import Data.Monoid (Monoid(..))-import Data.Word (Word16) import Data.String (IsString(..)) import qualified Data.Text.Fusion as S import qualified Data.Text.Fusion.Common as S import Data.Text.Fusion (stream, reverseStream, unstream) import Data.Text.Internal (Text(..), empty, text, textP) import qualified Prelude as P-import Data.Text.Unsafe (iter, iter_, reverseIter, unsafeHead, unsafeTail)+import Data.Text.Unsafe (Iter(..), iter, iter_, lengthWord16, reverseIter,+                         unsafeHead, unsafeTail) import Data.Text.UnsafeChar (unsafeChr) import qualified Data.Text.Encoding.Utf16 as U16 import Data.Text.Search (indices)@@ -292,8 +298,8 @@       len = len1+len2       x = do         arr <- A.unsafeNew len-        copy arr 0 arr1 off1 len1-        copy arr len1 arr2 off2 (len1+len2)+        A.copyI arr 0 arr1 off1 len1+        A.copyI arr len1 arr2 off2 (len1+len2)         return arr {-# INLINE append #-} @@ -304,14 +310,6 @@     unstream (S.append (stream t1) (stream t2)) = append t1 t2  #-} -copy :: forall s. A.MArray s Word16 -> Int -> A.Array Word16 -> Int -> Int-     -> ST s ()-copy dest i0 src j0 top = go i0 j0-  where-    go i j | i >= top  = return ()-           | otherwise = do A.unsafeWrite dest i (src `A.unsafeIndex` j)-                            go (i+1) (j+1)- -- | /O(1)/ Returns the first character of a 'Text', which must be -- non-empty.  Subject to fusion. head :: Text -> Char@@ -324,7 +322,7 @@ uncons t@(Text arr off len)     | len <= 0  = Nothing     | otherwise = Just (c, textP arr (off+d) (len-d))-    where (c,d) = iter t 0+    where Iter c d = iter t 0 {-# INLINE [1] uncons #-}  -- | Lifted from Control.Arrow and specialized.@@ -392,7 +390,11 @@ -- | /O(1)/ Tests whether a 'Text' is empty or not.  Subject to -- fusion. null :: Text -> Bool-null (Text _arr _off len) = assert (len >= 0) $ len <= 0+null (Text _arr _off len) =+#if defined(ASSERTS)+    assert (len >= 0) $+#endif+    len <= 0 {-# INLINE [1] null #-}  {-# RULES@@ -414,6 +416,51 @@ length t = S.length (stream t) {-# INLINE length #-} +-- | /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+-- greater than the number, and hence be more efficient.+compareLength :: Text -> Int -> Ordering+compareLength t n = S.compareLengthI (stream t) n+{-# INLINE [1] compareLength #-}++{-# RULES+"TEXT compareN/length -> compareLength" [~1] forall t n.+    compare (length t) n = compareLength t n+  #-}++{-# RULES+"TEXT ==N/length -> compareLength/==EQ" [~1] forall t n.+    (==) (length t) n = compareLength t n == EQ+  #-}++{-# RULES+"TEXT /=N/length -> compareLength//=EQ" [~1] forall t n.+    (/=) (length t) n = compareLength t n /= EQ+  #-}++{-# RULES+"TEXT <N/length -> compareLength/==LT" [~1] forall t n.+    (<) (length t) n = compareLength t n == LT+  #-}++{-# RULES+"TEXT <=N/length -> compareLength//=GT" [~1] forall t n.+    (<=) (length t) n = compareLength t n /= GT+  #-}++{-# RULES+"TEXT >N/length -> compareLength/==GT" [~1] forall t n.+    (>) (length t) n = compareLength t n == GT+  #-}++{-# RULES+"TEXT >=N/length -> compareLength//=LT" [~1] forall t n.+    (>=) (length t) n = compareLength t n /= LT+  #-}+ -- ----------------------------------------------------------------------------- -- * Transformations -- | /O(n)/ 'map' @f@ @t@ is the 'Text' obtained by applying @f@ to@@ -461,6 +508,12 @@ -- case conversion rules.  As a result, these functions may map one -- input character to two or three output characters. For examples, -- see the documentation of each function.+--+-- /Note/: In some languages, case conversion is a locale- and+-- context-dependent operation. The case conversion functions in this+-- module are /not/ locale sensitive. Programs that require locale+-- sensitivity should use appropriate versions of the case mapping+-- functions from the @text-icu@ package.  -- | /O(n)/ Convert a string to folded case.  This function is mainly -- useful for performing caseless (also known as case insensitive)@@ -597,14 +650,18 @@  -- | /O(n)/ Concatenate a list of 'Text's. concat :: [Text] -> Text-concat ts = Text (A.run go) 0 len+concat ts = case ts' of+              [] -> empty+              [t] -> t+              _ -> Text (A.run go) 0 len   where-    len = L.sum (L.map (\(Text _ _ l) -> l) ts)+    ts' = L.filter (not . null) ts+    len = L.sum $ L.map lengthWord16 ts'     go = do       arr <- A.unsafeNew len-      let step i (Text a o l) = let j = i + l in copy arr i a o j >> return j-      foldM step 0 ts >> return arr-{-# INLINE concat #-}+      let step i (Text a o l) =+            let !j = i + l in A.copyI arr i a o j >> return j+      foldM step 0 ts' >> return arr  -- | /O(n)/ Map a function over a 'Text' that results in a 'Text', and -- concatenate the results.@@ -712,7 +769,7 @@       arr <- A.unsafeNew len       let loop !d !i | i >= n    = return arr                      | otherwise = let m = d + l-                                   in copy arr d a o m >> loop m (i+1)+                                   in A.copyI arr d a o m >> loop m (i+1)       loop 0 0 {-# INLINE [1] replicate #-} @@ -774,8 +831,8 @@   #-}  -- | /O(n)/ 'drop' @n@, applied to a 'Text', returns the suffix of the--- 'Text' of length @n@, or the empty 'Text' if @n@ is greater than the--- length of the 'Text'. Subject to fusion.+-- 'Text' after the first @n@ characters, or the empty 'Text' if @n@+-- is greater than the length of the 'Text'. Subject to fusion. drop :: Int -> Text -> Text drop n t@(Text arr off len)     | n <= 0    = t@@ -802,7 +859,7 @@   where loop !i | i >= len    = t                 | p c         = loop (i+d)                 | otherwise   = textP arr off i-            where (c,d)       = iter t i+            where Iter c d    = iter t i {-# INLINE [1] takeWhile #-}  {-# RULES@@ -819,7 +876,7 @@   where loop !i !l | l >= len  = empty                    | p c       = loop (i+d) (l+d)                    | otherwise = Text arr (off+i) (len-l)-            where (c,d)        = iter t i+            where Iter c d     = iter t i {-# INLINE [1] dropWhile #-}  {-# RULES@@ -903,7 +960,7 @@   where k = loop 0         loop !i | i >= len || not (p c) = i                 | otherwise             = loop (i+d)-            where (c,d)                 = iter t i+            where Iter c d              = iter t i {-# INLINE spanBy #-}  -- | /O(n)/ 'breakBy' is like 'spanBy', but the prefix returned is@@ -919,7 +976,7 @@     loop t@(Text arr off len)         | null t    = []         | otherwise = text arr off n : loop (text arr (off+n) (len-n))-        where (c,d) = iter t 0+        where Iter c d = iter t 0               n     = d + findAIndexOrEnd (not . p c) (Text arr (off+d) (len-d))  -- | Returns the /array/ index (in units of 'Word16') at which a@@ -929,7 +986,7 @@ findAIndexOrEnd q t@(Text _arr _off len) = go 0     where go !i | i >= len || q c       = i                 | otherwise             = go (i+d)-                where (c,d)             = iter t i+                where Iter c d          = iter t i      -- | /O(n)/ Group characters in a string by equality. group :: Text -> [Text]@@ -1086,34 +1143,31 @@ {-# INLINE breakEnd #-}  -- | /O(n+m)/ Find all non-overlapping instances of @needle@ in--- @haystack@.  The first element of the returned pair is the prefix--- of @haystack@ prior to any matches of @needle@.  The second is a--- list of pairs.+-- @haystack@.  Each element of the returned list consists of a pair: ----- The first element of each pair in the list is a span from the--- beginning of a match to the beginning of the next match, while the--- second is a span from the beginning of the match to the end of the--- input.+-- * The entire string prior to the /k/th match (i.e. the prefix) --+-- * The /k/th match, followed by the remainder of the string+-- -- Examples: -- -- > find "::" ""--- > ==> ("", [])--- > find "/" "a/b/c/d"--- > ==> ("a", [("/b","/b/c/d"), ("/c","/c/d"), ("/d","/d")])+-- > ==> []+-- > find "/" "a/b/c/"+-- > ==> [("a", "/b/c/"), ("a/b", "/c/"), ("a/b/c", "/")] -- -- In (unlikely) bad cases, this function's time complexity degrades -- towards /O(n*m)/.-find :: Text -> Text -> (Text, [(Text, Text)])-find pat src@(Text arr off len)+--+-- The @needle@ parameter may not be empty.+find :: Text                    -- ^ @needle@ to search for+     -> Text                    -- ^ @haystack@ in which to search+     -> [(Text, Text)]+find pat src@(Text arr off slen)     | null pat  = emptyError "find"-    | otherwise = case indices pat src of-                    []     -> (src, [])-                    (x:xs) -> (chunk 0 x, go x xs)+    | otherwise = L.map step (indices pat src)   where-    go !s (x:xs) = (chunk s (x-s), chunk s (len-s)) : go x xs-    go  s _      = let c = chunk s (len-s)-                   in [(c,c)]+    step       x = (chunk 0 x, chunk x (slen-x))     chunk !n !l  = textP arr (n+off) l {-# INLINE find #-} @@ -1203,7 +1257,7 @@             then loop (start+1) (start+1)             else Text arr (start+off) (n-start) : loop (n+d) (n+d)         | otherwise = loop start (n+d)-        where (c,d) = iter t n+        where Iter c d = iter t n {-# INLINE words #-}  -- | /O(n)/ Breaks a 'Text' up into a list of 'Text's at@@ -1291,6 +1345,53 @@ "TEXT isInfixOf/singleton -> S.elem/S.stream" [~1] forall n h.     isInfixOf (singleton n) h = S.elem n (S.stream h)   #-}++-------------------------------------------------------------------------------+-- * View patterns++-- | /O(n)/ Returns the suffix of the second string if its prefix+-- matches the first.+--+-- Examples:+--+-- > prefixed "foo" "foobar" == Just "bar"+-- > prefixed "foo" "quux"   == Nothing+--+-- This is particularly useful with the @ViewPatterns@ extension to+-- GHC, as follows:+--+-- > {-# LANGUAGE ViewPatterns #-}+-- > import Data.Text as T+-- >+-- > fnordLength :: Text -> Int+-- > fnordLength (prefixed "fnord" -> Just suf) = T.length suf+-- > fnordLength _                              = -1+prefixed :: Text -> Text -> Maybe Text+prefixed p@(Text _arr _off plen) t@(Text arr off len)+    | p `isPrefixOf` t = Just $! textP arr (off+plen) (len-plen)+    | otherwise        = Nothing++-- | /O(n)/ Returns the prefix of the second string if its suffix+-- matches the first.+--+-- Examples:+--+-- > suffixed "bar" "foobar" == Just "foo"+-- > suffixed "foo" "quux"   == Nothing+--+-- This is particularly useful with the @ViewPatterns@ extension to+-- GHC, as follows:+--+-- > {-# LANGUAGE ViewPatterns #-}+-- > import Data.Text as T+-- >+-- > quuxLength :: Text -> Int+-- > quuxLength (suffixed "quux" -> Just pre) = T.length pre+-- > quuxLength _                             = -1+suffixed :: Text -> Text -> Maybe Text+suffixed p@(Text _arr _off plen) t@(Text arr off len)+    | p `isSuffixOf` t = Just $! textP arr off (len-plen)+    | otherwise        = Nothing  emptyError :: String -> a emptyError fun = P.error ("Data.Text." ++ fun ++ ": empty input")

@@ -1,9 +1,9 @@-{-# LANGUAGE BangPatterns, CPP, ExistentialQuantification, MagicHash,-             Rank2Types, ScopedTypeVariables, UnboxedTuples #-}+{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, RecordWildCards,+    UnboxedTuples #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} -- | -- Module      : Data.Text.Array--- Copyright   : (c) Bryan O'Sullivan 2009+-- Copyright   : (c) 2009, 2010 Bryan O'Sullivan -- -- License     : BSD-style -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,@@ -26,286 +26,247 @@ module Data.Text.Array     (     -- * Types-      IArray(..)-    , Elt(..)-    , Array+      Array     , MArray      -- * Functions+    , copyM+    , copyI     , empty-    , new-    , unsafeNew-    , unsafeFreeze+#if defined(ASSERTS)+    , length+#endif     , run     , run2     , toList-    , copy-    , unsafeCopy+    , unsafeFreeze+    , unsafeIndex+    , unsafeNew+    , unsafeWrite     ) where -#if 0-#define BOUNDS_CHECKING+#if defined(ASSERTS) -- This fugly hack is brought by GHC's apparent reluctance to deal -- with MagicHash and UnboxedTuples when inferring types. Eek!-#define CHECK_BOUNDS(_func_,_len_,_k_) \+# define CHECK_BOUNDS(_func_,_len_,_k_) \ if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.Text.Array." ++ (_func_) ++ ": bounds error, offset " ++ show (_k_) ++ ", length " ++ show (_len_)) else #else-#define CHECK_BOUNDS(_func_,_len_,_k_)+# define CHECK_BOUNDS(_func_,_len_,_k_) #endif -#if defined(__GLASGOW_HASKELL__) #include "MachDeps.h" +#if defined(ASSERTS)+import Control.Exception (assert)+#endif+import Data.Bits ((.&.))+import Data.Text.UnsafeShift (shiftL, shiftR) import GHC.Base (ByteArray#, MutableByteArray#, Int(..),-                 indexWord16Array#, newByteArray#,-                 readWord16Array#, unsafeCoerce#,-                 writeWord16Array#, (*#))-import GHC.Prim (Int#)+                 indexWord16Array#, indexWordArray#, newByteArray#,+                 readWord16Array#, readWordArray#, unsafeCoerce#,+                 writeWord16Array#, writeWordArray#) import GHC.ST (ST(..), runST)-import GHC.Word (Word16(..))--#elif defined(__HUGS__)--import Hugs.ByteArray (ByteArray, MutableByteArray, readByteArray,-                       newMutableByteArray, readMutableByteArray,-                       unsafeFreezeMutableByteArray, writeMutableByteArray)-import Foreign.Storable (Storable, sizeOf)-import Hugs.ST (ST(..), runST)--#else-# error not implemented for this compiler-#endif--import Control.Exception (assert)-import Data.Typeable (Typeable1(..), Typeable2(..), TyCon, mkTyCon, mkTyConApp)+import GHC.Word (Word16(..), Word(..)) import Prelude hiding (length, read) -#include "Typeable.h"- -- | Immutable array type.-data Array e = Array-    {-# UNPACK #-} !Int -- length (in units of e, not bytes)-#if defined(__GLASGOW_HASKELL__)-    ByteArray#-#elif defined(__HUGS__)-    !ByteArray+data Array = Array {+      aBA :: ByteArray#+#if defined(ASSERTS)+    , aLen :: {-# UNPACK #-} !Int -- length (in units of Word16, not bytes) #endif--INSTANCE_TYPEABLE1(Array,arrayTc,"Array")+    }  -- | Mutable array type, for use in the ST monad.-data MArray s e = MArray-    {-# UNPACK #-} !Int -- length (in units of e, not bytes)-#if defined(__GLASGOW_HASKELL__)-    (MutableByteArray# s)-#elif defined(__HUGS__)-    !(MutableByteArray s)+data MArray s = MArray {+      maBA :: MutableByteArray# s+#if defined(ASSERTS)+    , maLen :: {-# UNPACK #-} !Int -- length (in units of Word16, not bytes) #endif--INSTANCE_TYPEABLE2(MArray,mArrayTc,"MArray")+    } +#if defined(ASSERTS) -- | Operations supported by all arrays. class IArray a where     -- | Return the length of an array.     length :: a -> Int -instance IArray (Array e) where-    length (Array len _ba) = len+instance IArray Array where+    length = aLen     {-# INLINE length #-} -instance (Elt e, Show e) => Show (Array e) where-    show = show . toList--instance IArray (MArray s e) where-    length (MArray len _ba) = len+instance IArray (MArray s) where+    length = maLen     {-# INLINE length #-}--check :: IArray a => String -> a -> Int -> (a -> Int -> b) -> b-check func ary i f-    | i >= 0 && i < length ary = f ary i-    | otherwise = error ("Data.Array.Flat." ++ func ++ ": index out of bounds")-{-# INLINE check #-}---- | Operations supported by all elements that can be stored in--- arrays.-class Elt e where-    -- | Indicate how many bytes would be used for an array of the-    -- given size.-    bytesInArray :: Int -> e -> Int-    -- | Unchecked read of an immutable array.  May return garbage or-    -- crash on an out-of-bounds access.-    unsafeIndex :: Array e -> Int -> e-    -- | Unchecked read of a mutable array.  May return garbage or-    -- crash on an out-of-bounds access.-    unsafeRead :: MArray s e -> Int -> ST s e-    -- | Unchecked write of a mutable array.  May return garbage or-    -- crash on an out-of-bounds access.-    unsafeWrite :: MArray s e -> Int -> e -> ST s ()--    -- | Read an immutable array. An invalid index results in a-    -- runtime error.-    index :: Array e -> Int -> e-    index ary i = check "index" ary i unsafeIndex-    {-# INLINE index #-}--    -- | Read a mutable array. An invalid index results in a runtime-    -- error.-    read :: Array e -> Int -> ST s e-    read ary i = check "read" ary i read-    {-# INLINE read #-}--    -- | Write a mutable array. An invalid index results in a runtime-    -- error.-    write :: Array e -> Int -> ST s e-    write ary i = check "write" ary i write-    {-# INLINE write #-}---- | Freeze a mutable array. Do not mutate the 'MArray' afterwards!-unsafeFreeze :: MArray s e -> ST s (Array e)--#if defined(__GLASGOW_HASKELL__)--wORD16_SCALE :: Int# -> Int#-wORD16_SCALE n# = scale# *# n# where !(I# scale#) = SIZEOF_WORD16+#endif  -- | Create an uninitialized mutable array.-unsafeNew :: forall s e. Elt e => Int -> ST s (MArray s e)-unsafeNew n = assert (n >= 0) . ST $ \s1# ->-   case bytesInArray n (undefined :: e) of-     len@(I# len#) ->-#if defined(BOUNDS_CHECKING)+unsafeNew :: forall s. Int -> ST s (MArray s)+unsafeNew n =+#if defined(ASSERTS)+    assert (n >= 0) .+#endif+    ST $ \s1# ->+    case bytesInArray n of+      len@(I# len#) ->+#if defined(ASSERTS)          if len < 0 then error (show ("unsafeNew",len)) else #endif          case newByteArray# len# s1# of-           (# s2#, marr# #) -> (# s2#, MArray n marr# #)+           (# s2#, marr# #) -> (# s2#, MArray marr#+#if defined(ASSERTS)+                                  n+#endif+                                  #) {-# INLINE unsafeNew #-} -unsafeFreeze (MArray len mba#) = ST $ \s# ->-                                 (# s#, Array len (unsafeCoerce# mba#) #)-{-# INLINE unsafeFreeze #-}---- | Create a mutable array, with its elements initialized with the--- given value.-new :: forall s e. Elt e => Int -> e -> ST s (MArray s e)--#elif defined(__HUGS__)--unsafeIndexArray :: Storable e => Array e -> Int -> e-unsafeIndexArray (Array off len arr) i =-    assert (i >= 0 && i < len) $ readByteArray arr (off + i)--unsafeReadMArray :: Storable e => MArray s e -> Int -> ST s e-unsafeReadMArray (MArray _len marr) i =-    assert (i >= 0 && i < len) $ readMutableByteArray marr--unsafeWriteMArray :: Storable e => MArray s e -> Int -> e -> ST s ()-unsafeWriteMArray (MArray len marr) i =-    assert (i >= 0 && i < len) $ writeMutableByteArray marr---- | Create an uninitialized mutable array.-unsafeNew :: (Storable e) => Int -> ST s (MArray s e)-unsafeNew n = new undefined-  where new :: (Storable e) => e -> ST s (MArray s e)-        new unused = do-          marr <- newMutableByteArray (n * sizeOf unused)-          return (MArray n marr)--unsafeFreeze (MArray len mba) = do-  ba <- unsafeFreezeMutableByteArray mba-  return (Array 0 len ba)---- | Create a mutable array, with its elements initialized with the--- given value.-new :: (Storable e) => Int -> e -> ST s (MArray s e)+-- | Freeze a mutable array. Do not mutate the 'MArray' afterwards!+unsafeFreeze :: MArray s -> ST s Array+unsafeFreeze MArray{..} = ST $ \s# ->+                          (# s#, Array (unsafeCoerce# maBA)+#if defined(ASSERTS)+                             maLen #endif--new len initVal = do-  marr <- unsafeNew len-  sequence_ [unsafeWrite marr i initVal | i <- [0..len-1]]-  return marr--instance Elt Word16 where-#if defined(__GLASGOW_HASKELL__)+                             #)+{-# INLINE unsafeFreeze #-} -    bytesInArray (I# i#) _ = I# (wORD16_SCALE i#)-    {-# INLINE bytesInArray #-}+-- | Indicate how many bytes would be used for an array of the given+-- size.+bytesInArray :: Int -> Int+bytesInArray n = n `shiftL` 1+{-# INLINE bytesInArray #-} -    unsafeIndex (Array len ba#) i@(I# i#) =-      CHECK_BOUNDS("unsafeIndex",len,i)-        case indexWord16Array# ba# i# of r# -> (W16# r#)-    {-# INLINE unsafeIndex #-}+-- | Unchecked read of an immutable array.  May return garbage or+-- crash on an out-of-bounds access.+unsafeIndex :: Array -> Int -> Word16+unsafeIndex Array{..} i@(I# i#) =+  CHECK_BOUNDS("unsafeIndex",aLen,i)+    case indexWord16Array# aBA i# of r# -> (W16# r#)+{-# INLINE unsafeIndex #-} -    unsafeRead (MArray len mba#) i@(I# i#) = ST $ \s# ->-      CHECK_BOUNDS("unsafeRead",len,i)-      case readWord16Array# mba# i# s# of-        (# s2#, r# #) -> (# s2#, W16# r# #)-    {-# INLINE unsafeRead #-}+-- | Unchecked read of an immutable array.  May return garbage or+-- crash on an out-of-bounds access.+unsafeIndexWord :: Array -> Int -> Word+unsafeIndexWord Array{..} i@(I# i#) =+  CHECK_BOUNDS("unsafeIndexWord",aLen`div`wordFactor,i)+    case indexWordArray# aBA i# of r# -> (W# r#)+{-# INLINE unsafeIndexWord #-} -    unsafeWrite (MArray len marr#) i@(I# i#) (W16# e#) = ST $ \s1# ->-      CHECK_BOUNDS("unsafeWrite",len,i)-      case writeWord16Array# marr# i# e# s1# of-        s2# -> (# s2#, () #)-    {-# INLINE unsafeWrite #-}+-- | Unchecked read of a mutable array.  May return garbage or+-- crash on an out-of-bounds access.+unsafeRead :: MArray s -> Int -> ST s Word16+unsafeRead MArray{..} i@(I# i#) = ST $ \s# ->+  CHECK_BOUNDS("unsafeRead",maLen,i)+  case readWord16Array# maBA i# s# of+    (# s2#, r# #) -> (# s2#, W16# r# #)+{-# INLINE unsafeRead #-} -#elif defined(__HUGS__)+-- | Unchecked write of a mutable array.  May return garbage or crash+-- on an out-of-bounds access.+unsafeWrite :: MArray s -> Int -> Word16 -> ST s ()+unsafeWrite MArray{..} i@(I# i#) (W16# e#) = ST $ \s1# ->+  CHECK_BOUNDS("unsafeWrite",maLen,i)+  case writeWord16Array# maBA i# e# s1# of+    s2# -> (# s2#, () #)+{-# INLINE unsafeWrite #-} -    bytesInArray n w = sizeOf w * n-    unsafeIndex = unsafeIndexArray-    unsafeRead = unsafeReadMArray-    unsafeWrite = unsafeWriteMArray+-- | Unchecked read of a mutable array.  May return garbage or+-- crash on an out-of-bounds access.+unsafeReadWord :: MArray s -> Int -> ST s Word+unsafeReadWord MArray{..} i@(I# i#) = ST $ \s# ->+  CHECK_BOUNDS("unsafeRead64",maLen`div`wordFactor,i)+  case readWordArray# maBA i# s# of+    (# s2#, r# #) -> (# s2#, W# r# #)+{-# INLINE unsafeReadWord #-} -#endif+-- | Unchecked write of a mutable array.  May return garbage or crash+-- on an out-of-bounds access.+unsafeWriteWord :: MArray s -> Int -> Word -> ST s ()+unsafeWriteWord MArray{..} i@(I# i#) (W# e#) = ST $ \s1# ->+  CHECK_BOUNDS("unsafeWriteWord",maLen`div`wordFactor,i)+  case writeWordArray# maBA i# e# s1# of+    s2# -> (# s2#, () #)+{-# INLINE unsafeWriteWord #-}  -- | Convert an immutable array to a list.-toList :: Elt e => Array e -> [e]-toList a = loop 0-    where loop i | i < len   = unsafeIndex a i : loop (i+1)+toList :: Array -> Int -> Int -> [Word16]+toList ary off len = loop 0+    where loop i | i < len   = unsafeIndex ary (off+i) : loop (i+1)                  | otherwise = []-          len = length a  -- | An empty immutable array.-empty :: Elt e => Array e+empty :: Array empty = runST (unsafeNew 0 >>= unsafeFreeze)  -- | Run an action in the ST monad and return an immutable array of -- its result.-run :: Elt e => (forall s. ST s (MArray s e)) -> Array e+run :: (forall s. ST s (MArray s)) -> Array run k = runST (k >>= unsafeFreeze)  -- | Run an action in the ST monad and return an immutable array of -- its result paired with whatever else the action returns.-run2 :: Elt e => (forall s. ST s (MArray s e, a)) -> (Array e, a)+run2 :: (forall s. ST s (MArray s, a)) -> (Array, a) run2 k = runST (do                  (marr,b) <- k                  arr <- unsafeFreeze marr                  return (arr,b)) --- | Copy an array in its entirety. The destination array must be at--- least as big as the source.-copy :: Elt e => MArray s e     -- ^ source array-     -> MArray s e              -- ^ destination array-     -> ST s ()-copy src dest-    | length dest >= length src = copy_loop 0-    | otherwise                 = fail "Data.Text.Array.copy: array too small"-    where-      len = length src-      copy_loop i-          | i >= len  = return ()-          | otherwise = do unsafeRead src i >>= unsafeWrite dest i-                           copy_loop (i+1)-{-# INLINE copy #-}+-- | The amount to divide or multiply by to switch between units of+-- 'Word16' and units of 'Word'.+wordFactor :: Int+wordFactor = SIZEOF_HSWORD `shiftR` 1 --- | Unsafely copy the elements of an array.-unsafeCopy :: Elt e =>-              MArray s e -> Int -> MArray s e -> Int -> Int -> ST s ()-unsafeCopy src sidx dest didx count =+-- | Indicate whether an offset is word-aligned.+wordAligned :: Int -> Bool+wordAligned i = i .&. (wordFactor - 1) == 0++-- | Copy some elements of a mutable array.+copyM :: MArray s               -- ^ Destination+      -> Int                    -- ^ Destination offset+      -> MArray s               -- ^ Source+      -> Int                    -- ^ Source offset+      -> Int                    -- ^ Count+      -> ST s ()+copyM dest didx src sidx count =+#if defined(ASSERTS)     assert (sidx + count <= length src) .     assert (didx + count <= length dest) $-    copy_loop sidx didx 0+#endif+    if srem == 0 && drem == 0+    then fast_loop 0+    else slow_loop 0     where-      copy_loop !i !j !c-          | c >= count  = return ()-          | otherwise = do unsafeRead src i >>= unsafeWrite dest j-                           copy_loop (i+1) (j+1) (c+1)-{-# INLINE unsafeCopy #-}+      (swidx,srem) = sidx `divMod` wordFactor+      (dwidx,drem) = didx `divMod` wordFactor+      nwds         = count `div` wordFactor+      fast_loop !i+          | i >= nwds = slow_loop (i * wordFactor)+          | otherwise = do w <- unsafeReadWord src (swidx+i)+                           unsafeWriteWord dest (dwidx+i) w+                           fast_loop (i+1)+      slow_loop !i+          | i >= count= return ()+          | otherwise = do unsafeRead src (sidx+i) >>= unsafeWrite dest (didx+i)+                           slow_loop (i+1)++-- | Copy some elements of an immutable array.+copyI :: MArray s               -- ^ Destination+      -> Int                    -- ^ Destination offset+      -> Array                  -- ^ Source+      -> Int                    -- ^ Source offset+      -> Int                    -- ^ First offset in source /not/ to+                                -- copy (i.e. /not/ length)+      -> ST s ()+copyI dest i0 src j0 top+    | wordAligned i0 && wordAligned j0 = fast (i0 `div` wordFactor) (j0 `div` wordFactor)+    | otherwise = slow i0 j0+  where+    topwds = top `div` wordFactor+    fast !i !j+        | i >= topwds = slow (i * wordFactor) (j * wordFactor)+        | otherwise   = do unsafeWriteWord dest i (src `unsafeIndexWord` j)+                           fast (i+1) (j+1)+    slow !i !j+        | i >= top  = return ()+        | otherwise = do unsafeWrite dest i (src `unsafeIndex` j)+                         slow (i+1) (j+1)

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, Rank2Types #-}+{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}  -- | -- Module      : Data.Text.Encoding.Fusion@@ -31,7 +31,9 @@     , module Data.Text.Encoding.Fusion.Common     ) where +#if defined(ASSERTS) import Control.Exception (assert)+#endif import Data.ByteString.Internal (ByteString(..), mallocByteString, memcpy) import Data.Text.Fusion (Step(..), Stream(..)) import Data.Text.Fusion.Size@@ -73,9 +75,8 @@           | i+1 < l && U8.validate2 x1 x2 = Yield (U8.chr2 x1 x2) (i+2)           | i+2 < l && U8.validate3 x1 x2 x3 = Yield (U8.chr3 x1 x2 x3) (i+3)           | i+3 < l && U8.validate4 x1 x2 x3 x4 = Yield (U8.chr4 x1 x2 x3 x4) (i+4)-          | otherwise = decodeError "streamUtf8" "UTF-8" onErr mx (i+1)+          | otherwise = decodeError "streamUtf8" "UTF-8" onErr (Just x1) (i+1)           where-            mx = if i >= l then Nothing else Just x1             x1 = idx i             x2 = idx (i + 1)             x3 = idx (i + 2)@@ -182,7 +183,11 @@       {-# NOINLINE trimUp #-}       trimUp fp _ off = return $! PS fp 0 off       copy0 :: ForeignPtr Word8 -> Int -> Int -> IO (ForeignPtr Word8)-      copy0 !src !srcLen !destLen = assert (srcLen <= destLen) $ do+      copy0 !src !srcLen !destLen =+#if defined(ASSERTS)+        assert (srcLen <= destLen) $+#endif+        do           dest <- mallocByteString destLen           withForeignPtr src  $ \src'  ->               withForeignPtr dest $ \dest' ->

@@ -28,9 +28,9 @@     ) where  import Data.Bits ((.&.))-import Data.Char (ord) import Data.Text.Fusion (Step(..), Stream(..)) import Data.Text.Fusion.Internal (M(..), S(..))+import Data.Text.UnsafeChar (ord) import Data.Text.UnsafeShift (shiftR) import Data.Word (Word8) import qualified Data.Text.Encoding.Utf8 as U8

@@ -2,9 +2,9 @@  -- | -- Module      : Data.Text.Encoding.Utf16--- Copyright   : (c) Tom Harper 2008-2009,---               (c) Bryan O'Sullivan 2009,---               (c) Duncan Coutts 2009+-- Copyright   : (c) 2008, 2009 Tom Harper,+--               (c) 2009 Bryan O'Sullivan,+--               (c) 2009 Duncan Coutts -- -- License     : BSD-style -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,@@ -33,7 +33,7 @@ {-# INLINE chr2 #-}  validate1    :: Word16 -> Bool-validate1 x1 = (x1 >= 0 && x1 < 0xD800) || x1 > 0xDFFF+validate1 x1 = x1 < 0xD800 || x1 > 0xDFFF {-# INLINE validate1 #-}  validate2       ::  Word16 -> Word16 -> Bool

@@ -1,8 +1,8 @@ -- |--- Module      : Data.Text.Encoding.Utf16--- Copyright   : (c) Tom Harper 2008-2009,---               (c) Bryan O'Sullivan 2009,---               (c) Duncan Coutts 2009+-- Module      : Data.Text.Encoding.Utf32+-- Copyright   : (c) 2008, 2009 Tom Harper,+--               (c) 2009, 2010 Bryan O'Sullivan,+--               (c) 2009 Duncan Coutts -- -- License     : BSD-style -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,@@ -19,5 +19,5 @@ import Data.Word (Word32)  validate    :: Word32 -> Bool-validate x1 = (x1 >= 0x0 && x1 < 0xD800) || (x1 > 0xDFFF && x1 <= 0x10FFFF)+validate x1 = x1 < 0xD800 || (x1 > 0xDFFF && x1 <= 0x10FFFF) {-# INLINE validate #-}

@@ -1,10 +1,10 @@-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE CPP, MagicHash #-}  -- |--- Module      : Data.Text.Encoding.Utf16--- Copyright   : (c) Tom Harper 2008-2009,---               (c) Bryan O'Sullivan 2009,---               (c) Duncan Coutts 2009+-- Module      : Data.Text.Encoding.Utf8+-- Copyright   : (c) 2008, 2009 Tom Harper,+--               (c) 2009, 2010 Bryan O'Sullivan,+--               (c) 2009 Duncan Coutts -- -- License     : BSD-style -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,@@ -30,9 +30,11 @@     , validate4     ) where +#if defined(ASSERTS) import Control.Exception (assert)-import Data.Char (ord)+#endif import Data.Bits ((.&.))+import Data.Text.UnsafeChar (ord) import Data.Text.UnsafeShift (shiftR) import GHC.Exts import GHC.Word (Word8(..))@@ -47,14 +49,22 @@ {-# INLINE between #-}  ord2   :: Char -> (Word8,Word8)-ord2 c = assert (n >= 0x80 && n <= 0x07ff) (x1,x2)+ord2 c =+#if defined(ASSERTS)+    assert (n >= 0x80 && n <= 0x07ff)+#endif+    (x1,x2)     where       n  = ord c       x1 = fromIntegral $ (n `shiftR` 6) + 0xC0       x2 = fromIntegral $ (n .&. 0x3F)   + 0x80  ord3   :: Char -> (Word8,Word8,Word8)-ord3 c = assert (n >= 0x0800 && n <= 0xffff) (x1,x2,x3)+ord3 c =+#if defined(ASSERTS)+    assert (n >= 0x0800 && n <= 0xffff)+#endif+    (x1,x2,x3)     where       n  = ord c       x1 = fromIntegral $ (n `shiftR` 12) + 0xE0@@ -62,7 +72,11 @@       x3 = fromIntegral $ (n .&. 0x3F) + 0x80  ord4   :: Char -> (Word8,Word8,Word8,Word8)-ord4 c = assert (n >= 0x10000) (x1,x2,x3,x4)+ord4 c =+#if defined(ASSERTS)+    assert (n >= 0x10000)+#endif+    (x1,x2,x3,x4)     where       n  = ord c       x1 = fromIntegral $ (n `shiftR` 18) + 0xF0@@ -105,7 +119,7 @@ {-# INLINE chr4 #-}  validate1    :: Word8 -> Bool-validate1 x1 = between x1 0x00 0x7F+validate1 x1 = x1 <= 0x7F {-# INLINE validate1 #-}  validate2       :: Word8 -> Word8 -> Bool

@@ -1,7 +1,7 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns, CPP #-} -- | -- Module      : Data.Text.Foreign--- Copyright   : (c) Bryan O'Sullivan 2009+-- Copyright   : (c) 2009, 2010 Bryan O'Sullivan -- -- License     : BSD-style -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,@@ -23,11 +23,18 @@     -- * Unsafe conversion code     , lengthWord16     , unsafeCopyToPtr+    -- * Low-level manipulation+    -- $lowlevel+    , dropWord16+    , takeWord16     ) where +#if defined(ASSERTS) import Control.Exception (assert)+#endif import Control.Monad.ST (unsafeIOToST) import Data.Text.Internal (Text(..), empty)+import Data.Text.Unsafe (lengthWord16) import qualified Data.Text.Array as A import Data.Word (Word16) import Foreign.Marshal.Alloc (allocaBytes)@@ -53,7 +60,11 @@         -> Int                  -- ^ length of source array (in 'Word16' units)         -> IO Text fromPtr _   0   = return empty-fromPtr ptr len = assert (len > 0) $ return (Text arr 0 len)+fromPtr ptr len =+#if defined(ASSERTS)+    assert (len > 0) $+#endif+    return $! Text arr 0 len   where     arr = A.run (A.unsafeNew len >>= copy)     copy marr = loop ptr 0@@ -63,11 +74,44 @@           A.unsafeWrite marr i =<< unsafeIOToST (peek p)           loop (p `plusPtr` 2) (i + 1) --- | /O(1)/ Return the length of a 'Text' in units of 'Word16'.  This--- is useful for sizing a target array appropriately before using--- 'unsafeCopyToPtr'.-lengthWord16 :: Text -> Int-lengthWord16 (Text _arr _off len) = len+-- $lowlevel+--+-- Foreign functions that use UTF-16 internally may return indices in+-- units of 'Word16' instead of characters.  These functions may+-- safely be used with such indices, as they will adjust offsets if+-- necessary to preserve the validity of a Unicode string.++-- | /O(1)/ Return the prefix of the 'Text' of @n@ 'Word16' units in+-- length.+--+-- If @n@ would cause the 'Text' to end inside a surrogate pair, the+-- end of the prefix will be advanced by one additional 'Word16' unit+-- to maintain its validity.+takeWord16 :: Int -> Text -> Text+takeWord16 n t@(Text arr off len)+    | n <= 0               = empty+    | n >= len || m >= len = t+    | otherwise            = Text arr off m+  where+    m | w < 0xDB00 || w > 0xD8FF = n+      | otherwise                = n+1+    w = A.unsafeIndex arr (off+n-1)++-- | /O(1)/ Return the suffix of the 'Text', with @n@ 'Word16' units+-- dropped from its beginning.+--+-- If @n@ would cause the 'Text' to begin inside a surrogate pair, the+-- beginning of the suffix will be advanced by one additional 'Word16'+-- unit to maintain its validity.+dropWord16 :: Int -> Text -> Text+dropWord16 n t@(Text arr off len)+    | n <= 0               = t+    | n >= len || m >= len = empty+    | otherwise            = Text arr (off+m) (len-m)+  where+    m | w < 0xD800 || w > 0xDBFF = n+      | otherwise                = n+1+    w = A.unsafeIndex arr (off+n-1)  -- | /O(n)/ Copy a 'Text' to an array.  The array is assumed to be big -- enough to hold the contents of the entire 'Text'.

@@ -3,7 +3,7 @@ -- | -- Module      : Data.Text.Fusion -- Copyright   : (c) Tom Harper 2008-2009,---               (c) Bryan O'Sullivan 2009,+--               (c) Bryan O'Sullivan 2009-2010, --               (c) Duncan Coutts 2009 -- -- License     : BSD-style@@ -47,9 +47,8 @@                 Num(..), Ord(..), ($), (&&),                 fromIntegral, otherwise) import Data.Bits ((.&.))-import Data.Char (ord) import Data.Text.Internal (Text(..))-import Data.Text.UnsafeChar (unsafeChr, unsafeWrite)+import Data.Text.UnsafeChar (ord, unsafeChr, unsafeWrite) import Data.Text.UnsafeShift (shiftL, shiftR) import qualified Data.Text.Array as A import qualified Data.Text.Fusion.Common as S@@ -65,8 +64,7 @@ stream :: Text -> Stream Char stream (Text arr off len) = Stream next off (maxSize len)     where-      end = off+len-      {-# INLINE next #-}+      !end = off+len       next !i           | i >= end                   = Done           | n >= 0xD800 && n <= 0xDBFF = Yield (U16.chr2 n n2) (i + 2)@@ -94,20 +92,25 @@ -- | /O(n)/ Convert a 'Stream Char' into a 'Text'. unstream :: Stream Char -> Text unstream (Stream next0 s0 len) = I.textP (P.fst a) 0 (P.snd a)-    where-      mlen = upperBound 4 len-      a = A.run2 (A.unsafeNew mlen >>= (\arr -> loop arr mlen s0 0))-      loop arr !top !s !i-          | i + 1 >= top = case next0 s of-                            Done -> return (arr, i)-                            _    -> do-                              let top' = (top `shiftL` 1) + 1-                              arr' <- A.unsafeNew top'-                              A.copy arr arr' >> loop arr' top' s i-          | otherwise = case next0 s of-               Done       -> return (arr, i)-               Skip s'    -> loop arr top s' i-               Yield x s' -> unsafeWrite arr i x >>= loop arr top s'+  where+    a = A.run2 (A.unsafeNew mlen >>= \arr -> outer arr mlen s0 0)+      where mlen = upperBound 4 len+    outer arr top = loop+      where+        loop !s !i =+            case next0 s of+              Done          -> return (arr, i)+              Skip s'       -> loop s' i+              Yield x s'+                | j >= top  -> {-# SCC "unstream/resize" #-} do+                               let top' = (top + 1) `shiftL` 1+                               arr' <- A.unsafeNew top'+                               A.copyM arr' 0 arr 0 top+                               outer arr' top' s i+                | otherwise -> do d <- unsafeWrite arr i x+                                  loop s' (i+d)+                where j | ord x < 0x10000 = i+                        | otherwise       = i + 1 {-# INLINE [0] unstream #-} {-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-} @@ -132,10 +135,10 @@           Done -> return (marr, (j, len-j))               where j = i + 1           Skip s1    -> loop s1 i len marr-          Yield x s1 | i < least -> do-                       let newLen = len * 2+          Yield x s1 | i < least -> {-# SCC "reverse/resize" #-} do+                       let newLen = len `shiftL` 1                        marr' <- A.unsafeNew newLen-                       A.unsafeCopy marr 0 marr' (newLen-len) len+                       A.copyM marr' (newLen-len) marr 0 len                        write s1 (len+i) newLen marr'                      | otherwise -> write s1 i len marr             where n = ord x

@@ -29,6 +29,7 @@     , init     , null     , lengthI+    , compareLengthI     , isSingleton      -- * Transformations@@ -99,8 +100,8 @@     ) where  import Prelude (Bool(..), Char, Eq(..), Int, Integral, Maybe(..),-                Ord(..), String, (.), ($), (+), (-), (*), (++), (&&),-                fromIntegral, otherwise)+                Ord(..), Ordering(..), String, (.), ($), (+), (-), (*), (++),+                (&&), fromIntegral, otherwise) import qualified Data.List as L import qualified Prelude as P import Data.Int (Int64)@@ -158,8 +159,8 @@     next N = Done {-# INLINE [0] snoc #-} -data E l r = L {-# UNPACK #-} !l-           | R {-# UNPACK #-} !r+data E l r = L !l+           | R !r  -- | /O(n)/ Appends one Stream to the other. append :: Stream Char -> Stream Char -> Stream Char@@ -266,6 +267,25 @@                            Yield _ s' -> loop_length (z + 1) s' {-# 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+-- greater than the number, and hence be more efficient.+compareLengthI :: Integral a => Stream Char -> a -> Ordering+compareLengthI (Stream next s0 len) n = +    case exactly len of+      Nothing -> loop_cmp 0 s0+      Just i  -> compare (fromIntegral i) n+    where+      loop_cmp !z s  = case next s of+                         Done       -> compare z n+                         Skip    s' -> loop_cmp z s'+                         Yield _ s' | z > n     -> GT+                                    | otherwise -> loop_cmp (z + 1) s'+{-# INLINE[0] compareLengthI #-}+ -- | /O(n)/ Indicate whether a string contains exactly one element. isSingleton :: Stream Char -> Bool isSingleton (Stream next s0 _len) = loop 0 s0@@ -662,8 +682,8 @@ {-# INLINE [0] take #-}  -- | /O(n)/ drop n, applied to a stream, returns the suffix of the--- stream of length @n@, or the empty stream if @n@ is greater than the--- length of the stream.+-- stream after the first @n@ characters, or the empty stream if @n@+-- is greater than the length of the stream. drop :: Integral a => a -> Stream Char -> Stream Char drop n0 (Stream next0 s0 len) =     Stream next (J n0 :*: s0) (len - fromIntegral (max 0 n0))

@@ -34,16 +34,15 @@  -- | Specialised, strict Maybe-like type. data M a = N-         | J {-# UNPACK #-} !a+         | J !a  type M8 = M Word8  -- Restreaming state.-data S s = S {-# UNPACK #-} !s-    {-# UNPACK #-} !M8 {-# UNPACK #-} !M8 {-# UNPACK #-} !M8+data S s = S !s {-# UNPACK #-} !M8 {-# UNPACK #-} !M8 {-# UNPACK #-} !M8  infixl 2 :*:-data PairS a b = {-# UNPACK #-} !a :*: {-# UNPACK #-} !b+data PairS a b = !a :*: !b                  deriving (Eq, Ord, Show)  -- | Allow a function over a stream to switch between two states.

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} -- | -- Module      : Data.Text.Fusion.Internal@@ -15,6 +16,7 @@ module Data.Text.Fusion.Size     (       Size+    , exactly     , exactSize     , maxSize     , unknownSize@@ -26,19 +28,34 @@     , isEmpty     ) where +#if defined(ASSERTS) import Control.Exception (assert)+#endif  data Size = Exact {-# UNPACK #-} !Int -- ^ Exact size.           | Max   {-# UNPACK #-} !Int -- ^ Upper bound on size.           | Unknown                   -- ^ Unknown size.             deriving (Eq, Show) +exactly :: Size -> Maybe Int+exactly (Exact n) = Just n+exactly _         = Nothing+{-# INLINE exactly #-}+ exactSize :: Int -> Size-exactSize n = assert (n >= 0) Exact n+exactSize n =+#if defined(ASSERTS)+    assert (n >= 0)+#endif+    Exact n {-# INLINE exactSize #-}  maxSize :: Int -> Size-maxSize n = assert (n >= 0) Max n+maxSize n =+#if defined(ASSERTS)+    assert (n >= 0)+#endif+    Max n {-# INLINE maxSize #-}  unknownSize :: Size

@@ -1,8 +1,8 @@-{-# LANGUAGE BangPatterns, CPP, RecordWildCards #-}+{-# LANGUAGE BangPatterns, CPP, RecordWildCards, ScopedTypeVariables #-} -- | -- Module      : Data.Text.IO--- Copyright   : (c) Bryan O'Sullivan 2009,---               (c) Simon Marlow 2009+-- Copyright   : (c) 2009, 2010 Bryan O'Sullivan,+--               (c) 2009 Simon Marlow -- License     : BSD-style -- Maintainer  : bos@serpentine.com -- Stability   : experimental@@ -32,15 +32,16 @@     ) where  import Data.Text (Text)-import Prelude hiding (appendFile, getContents, getLine, interact, putStr,-                       putStrLn, readFile, writeFile)+import Prelude hiding (appendFile, catch, getContents, getLine, interact,+                       putStr, putStrLn, readFile, writeFile) import System.IO (Handle, IOMode(..), hPutChar, openFile, stdin, stdout,                   withFile) #if __GLASGOW_HASKELL__ <= 610 import qualified Data.ByteString.Char8 as B import Data.Text.Encoding (decodeUtf8, encodeUtf8) #else-import Control.Exception (throw)+import Control.Exception (catch, throw)+import Control.Monad (liftM2, when) import Data.IORef (readIORef, writeIORef) import qualified Data.Text as T import Data.Text.Fusion (stream)@@ -49,11 +50,13 @@ import GHC.IO.Buffer (Buffer(..), BufferState(..), CharBufElem, CharBuffer,                       RawCharBuffer, emptyBuffer, isEmptyBuffer, newCharBuffer,                       writeCharBuf)+import GHC.IO.Exception (IOException(ioe_type), IOErrorType(InappropriateType)) import GHC.IO.Handle.Internals (augmentIOError, hClose_help, wantReadableHandle,                                 wantWritableHandle) import GHC.IO.Handle.Text (commitBuffer') import GHC.IO.Handle.Types (BufferList(..), BufferMode(..), Handle__(..),-                            Newline(..))+                            HandleType(..), Newline(..))+import System.IO (hGetBuffering, hFileSize, hSetBuffering, hTell) import System.IO.Error (isEOFError) #endif @@ -87,25 +90,46 @@ #if __GLASGOW_HASKELL__ <= 610 hGetContents = fmap decodeUtf8 . B.hGetContents #else-hGetContents h = wantReadableHandle "hGetContents" h $ \hh -> do-                   (hh',ts) <- readAll hh-                   return (hh',T.concat ts)+hGetContents h = do+  chooseGoodBuffering h+  wantReadableHandle "hGetContents" h readAll  where   readAll hh@Handle__{..} = do-    buf <- readIORef haCharBuffer-    let readChunks = do-          t <- readChunk hh buf-          (hh',ts) <- readAll hh-          return (hh', t:ts)-    readChunks `catch` \e -> do-      (hh', _) <- hClose_help hh-      if isEOFError e-        then return $ if isEmptyBuffer buf-                      then (hh', [])-                      else (hh', [T.singleton '\r'])-        else throw (augmentIOError e "hGetContents" h)+    let catchError e+          | isEOFError e = do+              buf <- readIORef haCharBuffer+              return $ if isEmptyBuffer buf+                       then T.empty+                       else T.singleton '\r'+          | otherwise = throw (augmentIOError e "hGetContents" h)+        readChunks = do+          buf <- readIORef haCharBuffer+          t <- readChunk hh buf `catch` catchError+          if T.null t+            then return [t]+            else (t:) `fmap` readChunks+    ts <- readChunks+    (hh', _) <- hClose_help hh+    return (hh'{haType=ClosedHandle}, T.concat ts) #endif   +-- | Use a more efficient buffer size if we're reading in+-- block-buffered mode with the default buffer size.  When we can+-- determine the size of the handle we're reading, set the buffer size+-- to that, so that we can read the entire file in one chunk.+-- Otherwise, use a buffer size of at least 16KB.+chooseGoodBuffering :: Handle -> IO ()+chooseGoodBuffering h = do+  bufMode <- hGetBuffering h+  case bufMode of+    BlockBuffering Nothing -> do+      d <- catch (liftM2 (-) (hFileSize h) (hTell h)) $ \(e::IOException) ->+           if ioe_type e == InappropriateType+           then return 16384 -- faster than the 2KB default+           else throw e+      when (d > 0) . hSetBuffering h . BlockBuffering . Just . fromIntegral $ d+    _ -> return ()+ -- | Read a single line from a handle. hGetLine :: Handle -> IO Text #if __GLASGOW_HASKELL__ <= 610@@ -128,8 +152,10 @@   let str = stream t   case buffer_mode of      (NoBuffering, _)        -> hPutChars h str-     (LineBuffering, buf)    -> writeBlocks h True  nl buf str-     (BlockBuffering _, buf) -> writeBlocks h False nl buf str+     (LineBuffering, buf)    -> writeLines h nl buf str+     (BlockBuffering _, buf)+         | nl == CRLF        -> writeBlocksCRLF h buf str+         | otherwise         -> writeBlocksRaw h buf str  hPutChars :: Handle -> Stream Char -> IO () hPutChars h (Stream next0 s0 _len) = loop s0@@ -139,12 +165,18 @@                 Skip s'    -> loop s'                 Yield x s' -> hPutChar h x >> loop s' --- This function is largely lifted from GHC.IO.Handle.Text, but--- adapted to a coinductive stream of data instead of an inductive+-- The following functions are largely lifted from GHC.IO.Handle.Text,+-- but adapted to a coinductive stream of data instead of an inductive -- list.-writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> Stream Char-            -> IO ()-writeBlocks h lineBuffered nl buf0 (Stream next0 s0 _len) = outer s0 buf0+--+-- We have several variations of more or less the same code for+-- performance reasons.  Splitting the original buffered write+-- function into line- and block-oriented versions gave us a 2.1x+-- performance improvement.  Lifting out the raw/cooked newline+-- handling gave a few more percent on top.++writeLines :: Handle -> Newline -> Buffer CharBufElem -> Stream Char -> IO ()+writeLines h nl buf0 (Stream next0 s0 _len) = outer s0 buf0  where   outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)    where@@ -159,12 +191,40 @@                          then do n1 <- writeCharBuf raw n '\r'                                  writeCharBuf raw n1 '\n'                          else writeCharBuf raw n x-                   if lineBuffered-                     then commit n' True{-needs flush-} False >>= outer s'-                     else inner s' n'+                   commit n' True{-needs flush-} False >>= outer s'           | otherwise    -> writeCharBuf raw n x >>= inner s'     commit = commitBuffer h raw len +writeBlocksCRLF :: Handle -> Buffer CharBufElem -> Stream Char -> IO ()+writeBlocksCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0+ where+  outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)+   where+    inner !s !n =+      case next0 s of+        Done -> commit n False{-no flush-} True{-release-} >> return ()+        Skip s' -> inner s' n+        Yield x s'+          | n + 1 >= len -> commit n True{-needs flush-} False >>= outer s+          | x == '\n'    -> do n1 <- writeCharBuf raw n '\r'+                               writeCharBuf raw n1 '\n' >>= inner s'+          | otherwise    -> writeCharBuf raw n x >>= inner s'+    commit = commitBuffer h raw len++writeBlocksRaw :: Handle -> Buffer CharBufElem -> Stream Char -> IO ()+writeBlocksRaw h buf0 (Stream next0 s0 _len) = outer s0 buf0+ where+  outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)+   where+    inner !s !n =+      case next0 s of+        Done -> commit n False{-no flush-} True{-release-} >> return ()+        Skip s' -> inner s' n+        Yield x s'+          | n + 1 >= len -> commit n True{-needs flush-} False >>= outer s+          | otherwise    -> writeCharBuf raw n x >>= inner s'+    commit = commitBuffer h raw len+ -- This function is completely lifted from GHC.IO.Handle.Text. getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer) getSpareBuffer Handle__{haCharBuffer=ref, @@ -191,7 +251,7 @@ commitBuffer hdl !raw !sz !count flush release =    wantWritableHandle "commitAndReleaseBuffer" hdl $      commitBuffer' raw sz count flush release-{-# NOINLINE commitBuffer #-}+{-# INLINE commitBuffer #-} #endif  -- | Write a string to a handle, followed by a newline.

@@ -1,8 +1,8 @@ {-# LANGUAGE BangPatterns, CPP, RecordWildCards #-} -- | -- Module      : Data.Text.IO.Internal--- Copyright   : (c) Bryan O'Sullivan 2009,---               (c) Simon Marlow 2009+-- Copyright   : (c) 2009, 2010 Bryan O'Sullivan,+--               (c) 2009 Simon Marlow -- License     : BSD-style -- Maintainer  : bos@serpentine.com -- Stability   : experimental@@ -72,8 +72,8 @@               let pre | isEmptyBuffer buf1 = T.empty                       | otherwise          = T.singleton '\r'               writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }-              let str = reverse $ pre:t:ts-              if all T.null str+              let str = reverse . filter (not . T.null) $ pre:t:ts+              if null str                 then ioe_EOF                 else return str          Just new_buf -> hGetLineLoop hh (t:ts) new_buf@@ -105,7 +105,7 @@  | otherwise     = withRawBuffer buf $ go  where   go pbuf = do-    let t = unstream (Stream next r (maxSize (w-r)))+    let !t = unstream (Stream next r (maxSize (w-r)))         w' = w - 1     return $ if ix w' == '\r'              then (t,w')@@ -127,7 +127,7 @@ getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =   case bufferElems buf of     -- buffer empty: read some more-    0 -> readTextDevice handle_ buf+    0 -> {-# SCC "readTextDevice" #-} readTextDevice handle_ buf      -- if the buffer has a single '\r' in it and we're doing newline     -- translation: read some more@@ -145,7 +145,7 @@                  return buf      -- buffer has some chars in it already: just return it-    _otherwise -> return buf+    _otherwise -> {-# SCC "otherwise" #-} return buf  -- | Read a single chunk of strict text from a buffer. Used by both -- the strict and lazy implementations of hGetContents.

@@ -1,10 +1,10 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-}  -- | -- Module      : Data.Text.Internal--- Copyright   : (c) Tom Harper 2008-2009,---               (c) Bryan O'Sullivan 2009,---               (c) Duncan Coutts 2009+-- Copyright   : (c) 2008, 2009 Tom Harper,+--               (c) 2009, 2010 Bryan O'Sullivan,+--               (c) 2009 Duncan Coutts -- -- License     : BSD-style -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,@@ -28,28 +28,31 @@     , showText     ) where +#if defined(ASSERTS) import Control.Exception (assert)+#endif import qualified Data.Text.Array as A import Data.Typeable (Typeable)-import Data.Word (Word16)  -- | A space efficient, packed, unboxed Unicode text type. data Text = Text-    {-# UNPACK #-} !(A.Array Word16) -- payload+    {-# UNPACK #-} !A.Array          -- payload     {-# UNPACK #-} !Int              -- offset     {-# UNPACK #-} !Int              -- length     deriving (Typeable)  -- | Smart constructor.-text :: A.Array Word16 -> Int -> Int -> Text+text :: A.Array -> Int -> Int -> Text text arr off len =-    assert (len >= 0) .-    assert (off >= 0) .-    assert (alen == 0 || len == 0 || off < alen) .-    assert (len == 0 || c < 0xDC00 || c > 0xDFFF) $-    Text arr off len-  where c    = A.unsafeIndex arr off-        alen = A.length arr+#if defined(ASSERTS)+  let c    = A.unsafeIndex arr off+      alen = A.length arr+  in assert (len >= 0) .+     assert (off >= 0) .+     assert (alen == 0 || len == 0 || off < alen) .+     assert (len == 0 || c < 0xDC00 || c > 0xDFFF) $+#endif+     Text arr off len {-# INLINE text #-}  -- | /O(1)/ The empty 'Text'.@@ -59,7 +62,7 @@  -- | Construct a 'Text' without invisibly pinning its byte array in -- memory if its length has dwindled to zero.-textP :: A.Array Word16 -> Int -> Int -> Text+textP :: A.Array -> Int -> Int -> Text textP arr off len | len == 0  = empty                   | otherwise = text arr off len {-# INLINE textP #-}@@ -67,5 +70,5 @@ -- | A useful 'show'-like function for debugging purposes. showText :: Text -> String showText (Text arr off len) =-    "Text " ++ (show . take (off+len) . A.toList) arr ++ ' ' :+    "Text " ++ show (A.toList arr off len) ++ ' ' :             show off ++ ' ' : show len

@@ -2,7 +2,7 @@ {-# LANGUAGE BangPatterns, CPP #-} -- | -- Module      : Data.Text.Lazy--- Copyright   : (c) Bryan O'Sullivan 2009+-- Copyright   : (c) 2009, 2010 Bryan O'Sullivan -- -- License     : BSD-style -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,@@ -39,6 +39,10 @@     , empty     , fromChunks     , toChunks+    , toStrict+    , fromStrict+    , foldrChunks+    , foldlChunks      -- * Basic interface     , cons@@ -51,6 +55,7 @@     , init     , null     , length+    , compareLength      -- * Transformations     , map@@ -144,6 +149,10 @@     , isSuffixOf     , isInfixOf +    -- ** View patterns+    , prefixed+    , suffixed+     -- * Searching     , filter     , find@@ -165,7 +174,7 @@     ) where  import Prelude (Char, Bool(..), Maybe(..), String,-                Eq(..), Ord(..), Read(..), Show(..),+                Eq(..), Ord(..), Ordering, Read(..), Show(..),                 (&&), (+), (-), (.), ($), (++),                 div, error, flip, fromIntegral, not, otherwise) import qualified Prelude as P@@ -245,6 +254,8 @@ unpack t = S.unstreamList (stream t) {-# INLINE [1] unpack #-} +-- | /O(1)/ Convert a character into a Text.+-- Subject to fusion. singleton :: Char -> Text singleton c = Chunk (T.singleton c) Empty {-# INLINE [1] singleton #-}@@ -264,6 +275,22 @@ toChunks :: Text -> [T.Text] toChunks cs = foldrChunks (:) [] cs +-- | /O(n)/ Convert a lazy 'Text' into a strict 'T.Text'.+toStrict :: Text -> T.Text+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 = chunk t Empty+{-# INLINE [1] fromStrict #-}++-- -----------------------------------------------------------------------------+-- * Basic functions++-- | /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. cons :: Char -> Text -> Text cons c t = Chunk (T.singleton c) t {-# INLINE [1] cons #-}@@ -275,6 +302,8 @@     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. snoc :: Text -> Char -> Text snoc t c = foldrChunks Chunk (singleton c) t {-# INLINE [1] snoc #-}@@ -380,6 +409,8 @@     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 go l t = l + fromIntegral (T.length t)@@ -392,6 +423,20 @@     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+-- greater than the number, and hence be more efficient.+compareLength :: Text -> Int64 -> Ordering+compareLength t n = S.compareLengthI (stream t) n+{-# INLINE [1] compareLength #-}++-- We don't apply those otherwise appealing length-to-compareLength+-- rewrite rules here, because they can change the strictness+-- properties of code.+ -- | /O(n)/ 'map' @f@ @t@ is the 'Text' obtained by applying @f@ to -- each element of @t@.  Subject to array fusion. map :: (Char -> Char) -> Text -> Text@@ -724,8 +769,8 @@   #-}  -- | /O(n)/ 'drop' @n@, applied to a 'Text', returns the suffix of the--- 'Text' of length @n@, or the empty 'Text' if @n@ is greater than the--- length of the 'Text'. Subject to fusion.+-- 'Text' after the first @n@ characters, or the empty 'Text' if @n@+-- is greater than the length of the 'Text'. Subject to fusion. drop :: Int64 -> Text -> Text drop i t0     | i <= 0    = t0@@ -915,38 +960,37 @@ {-# INLINE breakEnd #-}  -- | /O(n+m)/ Find all non-overlapping instances of @needle@ in--- @haystack@.  The first element of the returned pair is the prefix--- of @haystack@ prior to any matches of @needle@.  The second is a--- list of pairs.+-- @haystack@.  Each element of the returned list consists of a pair: ----- The first element of each pair in the list is a span from the--- beginning of a match to the beginning of the next match, while the--- second is a span from the beginning of the match to the end of the--- input.+-- * The entire string prior to the /k/th match (i.e. the prefix) --+-- * The /k/th match, followed by the remainder of the string+-- -- Examples: -- -- > find "::" ""--- > ==> ("", [])--- > find "/" "a/b/c/d"--- > ==> ("a", [("/b","/b/c/d"), ("/c","/c/d"), ("/d","/d")])+-- > ==> []+-- > find "/" "a/b/c/"+-- > ==> [("a", "/b/c/"), ("a/b", "/c/"), ("a/b/c", "/")] -- -- This function is strict in its first argument, and lazy in its -- second. -- -- In (unlikely) bad cases, this function's time complexity degrades -- towards /O(n*m)/.-find :: Text -> Text -> (Text, [(Text, Text)])+--+-- The @needle@ parameter may not be empty.+find :: Text                    -- ^ @needle@ to search for+     -> Text                    -- ^ @haystack@ in which to search+     -> [(Text, Text)] find pat src     | null pat  = emptyError "find"-    | otherwise = case indices pat src of-                    []     -> (src, [])-                    (x:xs) -> let h :*: t = splitAtWord x src-                              in (h, go x xs t)+    | otherwise = go 0 empty src (indices pat src)   where-    go !i (x:xs) cs = let h :*: t = splitAtWord (x-i) cs-                      in (h, cs) : go x xs t-    go  _ _      cs = [(cs,cs)]+    go !n p s (x:xs) = let h :*: t = splitAtWord (x-n) s+                           h'      = append p h+                       in (h',t) : go x h' t xs+    go _  _ _ _      = []  -- | /O(n)/ 'breakBy' is like 'spanBy', but the prefix returned is over -- elements that fail the predicate @p@.@@ -1157,6 +1201,55 @@     isInfixOf (singleton n) h = S.elem n (S.stream h)   #-} +-------------------------------------------------------------------------------+-- * View patterns++-- | /O(n)/ Returns the suffix of the second string if its prefix+-- matches the first.+--+-- Examples:+--+-- > prefixed "foo" "foobar" == Just "bar"+-- > prefixed "foo" "quux"   == Nothing+--+-- This is particularly useful with the @ViewPatterns@ extension to+-- GHC, as follows:+--+-- > {-# LANGUAGE ViewPatterns #-}+-- > import Data.Text as T+-- >+-- > fnordLength :: Text -> Int+-- > fnordLength (prefixed "fnord" -> Just suf) = T.length suf+-- > fnordLength _                              = -1+prefixed :: Text -> Text -> Maybe Text+-- Yes, this could be much more efficient.+prefixed p t+    | p `isPrefixOf` t = Just (drop (length p) t)+    | otherwise        = Nothing++-- | /O(n)/ Returns the prefix of the second string if its suffix+-- matches the first.+--+-- Examples:+--+-- > suffixed "bar" "foobar" == Just "foo"+-- > suffixed "foo" "quux"   == Nothing+--+-- This is particularly useful with the @ViewPatterns@ extension to+-- GHC, as follows:+--+-- > {-# LANGUAGE ViewPatterns #-}+-- > import Data.Text as T+-- >+-- > quuxLength :: Text -> Int+-- > quuxLength (suffixed "quux" -> Just pre) = T.length pre+-- > quuxLength _                             = -1+suffixed :: Text -> Text -> Maybe Text+-- Yes, this could be much more efficient.+suffixed p t+    | p `isSuffixOf` t = Just (take (length t - length p) t)+    | otherwise        = Nothing+ -- | /O(n)/ 'filter', applied to a predicate and a 'Text', -- returns a 'Text' containing those characters that satisfy the -- predicate.@@ -1194,9 +1287,9 @@ count :: Text -> Text -> Int64 count pat src     | null pat        = emptyError "count"-    | otherwise       = len (indices pat src)-  where len []     = 0-        len (_:xs) = 1 + len xs+    | otherwise       = go 0 (indices pat src)+  where go !n []     = n+        go !n (_:xs) = go (n+1) xs {-# INLINE [1] count #-}  {-# RULES

@@ -1,9 +1,9 @@-{-# LANGUAGE BangPatterns, Rank2Types #-}+{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}  ----------------------------------------------------------------------------- -- | -- Module      : Data.Text.Lazy.Builder--- Copyright   : Johan Tibell+-- Copyright   : (c) 2010 Johan Tibell -- License     : BSD3-style (see LICENSE) --  -- Maintainer  : Johan Tibell <johan.tibell@gmail.com>@@ -29,18 +29,17 @@    , flush    ) where -import Control.Exception (assert) import Control.Monad.ST (ST, runST) import Data.Bits ((.&.))-import Data.Char (ord) import Data.Monoid (Monoid(..)) import Data.Text.Internal (Text(..))-import Data.Text.Lazy.Internal (defaultChunkSize)+import Data.Text.Lazy.Internal (smallChunkSize) import Data.Text.Unsafe (inlineInterleaveST)+import Data.Text.UnsafeChar (ord, unsafeWrite) import Data.Text.UnsafeShift (shiftR)-import Data.Word (Word16) import Prelude hiding (map, putChar) +import qualified Data.String as String import qualified Data.Text as S import qualified Data.Text.Array as A import qualified Data.Text.Lazy as L@@ -70,6 +69,13 @@    mappend = append    {-# INLINE mappend #-} +instance String.IsString Builder where+    fromString = fromString+    {-# INLINE fromString #-}++instance Show Builder where+    show = L.unpack . toLazyText+ ------------------------------------------------------------------------  -- | /O(1)./ The empty Builder, satisfying@@ -113,7 +119,7 @@ fromText :: S.Text -> Builder fromText t@(Text arr off l)     | S.null t       = empty-    | l <= copyLimit = writeN l $ \marr o -> unsafeCopy arr off marr o l+    | l <= copyLimit = writeN l $ \marr o -> A.copyI marr o arr off (l+o)     | otherwise      = flush `append` mapBuilder (t :) {-# INLINE [1] fromText #-} @@ -133,13 +139,15 @@             | l <= 1 = do                 arr <- A.unsafeFreeze marr                 let !t = Text arr o u-                marr' <- A.unsafeNew defaultChunkSize-                ts <- inlineInterleaveST (loop marr' 0 0 defaultChunkSize s)+                marr' <- A.unsafeNew chunkSize+                ts <- inlineInterleaveST (loop marr' 0 0 chunkSize s)                 return $ t : ts             | otherwise = do                 n <- unsafeWrite marr (o+u) c                 loop marr o (u+n) (l-n) cs     in loop p0 o0 u0 l0 str+  where+    chunkSize = smallChunkSize {-# INLINE fromString #-}  -- | /O(1)./ A Builder taking a lazy 'L.Text', satisfying@@ -153,7 +161,7 @@ ------------------------------------------------------------------------  -- Our internal buffer type-data Buffer s = Buffer {-# UNPACK #-} !(A.MArray s Word16)+data Buffer s = Buffer {-# UNPACK #-} !(A.MArray s)                        {-# UNPACK #-} !Int  -- offset                        {-# UNPACK #-} !Int  -- used units                        {-# UNPACK #-} !Int  -- length left@@ -164,7 +172,7 @@ -- buffer size.  The construction work takes place if and when the -- relevant part of the lazy 'L.Text' is demanded. toLazyText :: Builder -> L.Text-toLazyText = toLazyTextWith defaultChunkSize+toLazyText = toLazyTextWith smallChunkSize  -- | /O(n)./ Extract a lazy 'L.Text' from a 'Builder', using the given -- size for the initial buffer.  The construction work takes place if@@ -199,6 +207,7 @@ withSize :: (Int -> Builder) -> Builder withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->     runBuilder (f l) k buf+{-# INLINE withSize #-}  -- | Map the resulting list of texts. mapBuilder :: ([S.Text] -> [S.Text]) -> Builder@@ -225,16 +234,16 @@ ensureFree !n = withSize $ \ l ->     if n <= l     then empty-    else flush `append'` withBuffer (const (newBuffer (max n defaultChunkSize)))+    else flush `append'` withBuffer (const (newBuffer (max n smallChunkSize))) {-# INLINE [0] ensureFree #-}  -- | Ensure that @n@ many elements are available, and then use @f@ to -- write some elements into the memory.-writeN :: Int -> (forall s. A.MArray s Word16 -> Int -> ST s ()) -> Builder+writeN :: Int -> (forall s. A.MArray s -> Int -> ST s ()) -> Builder writeN n f = ensureFree n `append'` withBuffer (writeNBuffer n f) {-# INLINE [0] writeN #-} -writeNBuffer :: Int -> (A.MArray s Word16 -> Int -> ST s ()) -> (Buffer s)+writeNBuffer :: Int -> (A.MArray s -> Int -> ST s ()) -> (Buffer s)              -> ST s (Buffer s) writeNBuffer n f (Buffer p o u l) = do     f p (o+u)@@ -247,39 +256,6 @@     return $! Buffer arr 0 0 size {-# INLINE newBuffer #-} --- | Unsafely copy the elements of an array.-unsafeCopy :: A.Elt e =>-              A.Array e -> Int -> A.MArray s e -> Int -> Int -> ST s ()-unsafeCopy src sidx dest didx count =-    assert (sidx + count <= A.length src) .-    assert (didx + count <= A.length dest) $-    copy_loop sidx didx 0-  where-    copy_loop !i !j !c-        | c >= count  = return ()-        | otherwise = do A.unsafeWrite dest j (A.unsafeIndex src i)-                         copy_loop (i+1) (j+1) (c+1)-{-# INLINE unsafeCopy #-}---- Write a character to the array, starting at the specified offset--- @i@.  Returns the number of elements written.-unsafeWrite :: A.MArray s Word16 -> Int -> Char -> ST s Int-unsafeWrite marr i c-    | n < 0x10000 = do-        assert (i >= 0) . assert (i < A.length marr) $-          A.unsafeWrite marr i (fromIntegral n)-        return 1-    | otherwise = do-        assert (i >= 0) . assert (i < A.length marr - 1) $-          A.unsafeWrite marr i lo-        A.unsafeWrite marr (i+1) hi-        return 2-    where n = ord c-          m = n - 0x10000-          lo = fromIntegral $ (m `shiftR` 10) + 0xD800-          hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00-{-# INLINE unsafeWrite #-}- ------------------------------------------------------------------------ -- Some nice rules for Builder @@ -292,13 +268,13 @@  {-# RULES -"append/writeN" forall a b (f::forall s. A.MArray s Word16 -> Int -> ST s ())-                           (g::forall s. A.MArray s Word16 -> Int -> ST s ()) ws.+"append/writeN" forall a b (f::forall s. A.MArray s -> Int -> ST s ())+                           (g::forall s. A.MArray s -> Int -> ST s ()) ws.         append (writeN a f) (append (writeN b g) ws) =             append (writeN (a+b) (\marr o -> f marr o >> g marr (o+a))) ws -"writeN/writeN" forall a b (f::forall s. A.MArray s Word16 -> Int -> ST s ())-                           (g::forall s. A.MArray s Word16 -> Int -> ST s ()).+"writeN/writeN" forall a b (f::forall s. A.MArray s -> Int -> ST s ())+                           (g::forall s. A.MArray s -> Int -> ST s ()).         append (writeN a f) (writeN b g) =             writeN (a+b) (\marr o -> f marr o >> g marr (o+a)) 

@@ -1,6 +1,6 @@ -- | -- Module      : Data.Text.Lazy.Encoding--- Copyright   : (c) Bryan O'Sullivan 2009+-- Copyright   : (c) 2009, 2010 Bryan O'Sullivan -- -- License     : BSD-style -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,@@ -17,39 +17,110 @@ module Data.Text.Lazy.Encoding     (     -- * Decoding ByteStrings to Text-    --  decodeASCII-      decodeUtf8+      decodeASCII+    , decodeUtf8+    , decodeUtf16LE+    , decodeUtf16BE+    , decodeUtf32LE+    , decodeUtf32BE+    -- ** Controllable error handling     , decodeUtf8With-    --, decodeUtf16LE-    --, decodeUtf16BE-    --, decodeUtf32LE-    --, decodeUtf32BE+    , decodeUtf16LEWith+    , decodeUtf16BEWith+    , decodeUtf32LEWith+    , decodeUtf32BEWith      -- * Encoding Text to ByteStrings     , encodeUtf8-    --, encodeUtf16LE-    --, encodeUtf16BE-    --, encodeUtf32LE-    --, encodeUtf32BE+    , encodeUtf16LE+    , encodeUtf16BE+    , encodeUtf32LE+    , encodeUtf32BE     ) where -import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as B import Data.Text.Encoding.Error (OnDecodeError, strictDecode)-import Data.Text.Lazy (Text)+import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy.Fusion as F+import Data.Text.Lazy.Internal (Text(..), chunk, foldrChunks) import qualified Data.Text.Lazy.Encoding.Fusion as E +-- | Decode a 'ByteString' containing 7-bit ASCII encoded text.+decodeASCII :: B.ByteString -> Text+decodeASCII bs = foldr (chunk . TE.decodeASCII) Empty (B.toChunks bs)+{-# INLINE decodeASCII #-}+ -- | Decode a 'ByteString' containing UTF-8 encoded text.-decodeUtf8With :: OnDecodeError -> ByteString -> Text+decodeUtf8With :: OnDecodeError -> B.ByteString -> Text decodeUtf8With onErr bs = F.unstream (E.streamUtf8 onErr bs) {-# INLINE decodeUtf8With #-}  -- | Decode a 'ByteString' containing UTF-8 encoded text.-decodeUtf8 :: ByteString -> Text+decodeUtf8 :: B.ByteString -> Text decodeUtf8 = decodeUtf8With strictDecode {-# INLINE decodeUtf8 #-}  -- | Encode text using UTF-8 encoding.-encodeUtf8 :: Text -> ByteString+encodeUtf8 :: Text -> B.ByteString encodeUtf8 txt = E.unstream (E.restreamUtf8 (F.stream txt)) {-# INLINE encodeUtf8 #-}++-- | Decode text from little endian UTF-16 encoding.+decodeUtf16LEWith :: OnDecodeError -> B.ByteString -> Text+decodeUtf16LEWith onErr bs = F.unstream (E.streamUtf16LE onErr bs)+{-# INLINE decodeUtf16LEWith #-}++-- | Decode text from little endian UTF-16 encoding.+decodeUtf16LE :: B.ByteString -> Text+decodeUtf16LE = decodeUtf16LEWith strictDecode+{-# INLINE decodeUtf16LE #-}++-- | Decode text from big endian UTF-16 encoding.+decodeUtf16BEWith :: OnDecodeError -> B.ByteString -> Text+decodeUtf16BEWith onErr bs = F.unstream (E.streamUtf16BE onErr bs)+{-# INLINE decodeUtf16BEWith #-}++-- | Decode text from big endian UTF-16 encoding.+decodeUtf16BE :: B.ByteString -> Text+decodeUtf16BE = decodeUtf16BEWith strictDecode+{-# INLINE decodeUtf16BE #-}++-- | Encode text using little endian UTF-16 encoding.+encodeUtf16LE :: Text -> B.ByteString+encodeUtf16LE txt = B.fromChunks (foldrChunks ((:) . TE.encodeUtf16LE) [] txt)+{-# INLINE encodeUtf16LE #-}++-- | Encode text using big endian UTF-16 encoding.+encodeUtf16BE :: Text -> B.ByteString+encodeUtf16BE txt = B.fromChunks (foldrChunks ((:) . TE.encodeUtf16BE) [] txt)+{-# INLINE encodeUtf16BE #-}++-- | Decode text from little endian UTF-32 encoding.+decodeUtf32LEWith :: OnDecodeError -> B.ByteString -> Text+decodeUtf32LEWith onErr bs = F.unstream (E.streamUtf32LE onErr bs)+{-# INLINE decodeUtf32LEWith #-}++-- | Decode text from little endian UTF-32 encoding.+decodeUtf32LE :: B.ByteString -> Text+decodeUtf32LE = decodeUtf32LEWith strictDecode+{-# INLINE decodeUtf32LE #-}++-- | Decode text from big endian UTF-32 encoding.+decodeUtf32BEWith :: OnDecodeError -> B.ByteString -> Text+decodeUtf32BEWith onErr bs = F.unstream (E.streamUtf32BE onErr bs)+{-# INLINE decodeUtf32BEWith #-}++-- | Decode text from big endian UTF-32 encoding.+decodeUtf32BE :: B.ByteString -> Text+decodeUtf32BE = decodeUtf32BEWith strictDecode+{-# INLINE decodeUtf32BE #-}++-- | Encode text using little endian UTF-32 encoding.+encodeUtf32LE :: Text -> B.ByteString+encodeUtf32LE txt = B.fromChunks (foldrChunks ((:) . TE.encodeUtf32LE) [] txt)+{-# INLINE encodeUtf32LE #-}++-- | Encode text using big endian UTF-32 encoding.+encodeUtf32BE :: Text -> B.ByteString+encodeUtf32BE txt = B.fromChunks (foldrChunks ((:) . TE.encodeUtf32BE) [] txt)+{-# INLINE encodeUtf32BE #-}

@@ -1,8 +1,8 @@-{-# LANGUAGE BangPatterns, Rank2Types #-}+{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}  -- | -- Module      : Data.Text.Lazy.Encoding.Fusion--- Copyright   : (c) Bryan O'Sullivan 2009+-- Copyright   : (c) 2009, 2010 Bryan O'Sullivan -- -- License     : BSD-style -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com, @@ -17,11 +17,11 @@     (     -- * Streaming     --  streamASCII-     streamUtf8-    --, streamUtf16LE-    --, streamUtf16BE-    --, streamUtf32LE-    --, streamUtf32BE+      streamUtf8+    , streamUtf16LE+    , streamUtf16BE+    , streamUtf32LE+    , streamUtf32BE      -- * Unstreaming     , unstream@@ -36,14 +36,19 @@ import Data.Text.Encoding.Error import Data.Text.Fusion (Step(..), Stream(..)) import Data.Text.Fusion.Size-import Data.Text.UnsafeChar (unsafeChr8)-import Data.Word (Word8)+import Data.Text.UnsafeChar (unsafeChr, unsafeChr8, unsafeChr32)+import Data.Text.UnsafeShift (shiftL)+import Data.Word (Word8, Word16, Word32) import qualified Data.Text.Encoding.Utf8 as U8+import qualified Data.Text.Encoding.Utf16 as U16+import qualified Data.Text.Encoding.Utf32 as U32 import System.IO.Unsafe (unsafePerformIO) import Foreign.ForeignPtr (withForeignPtr, ForeignPtr) import Foreign.Storable (pokeByteOff) import Data.ByteString.Internal (mallocByteString, memcpy)+#if defined(ASSERTS) import Control.Exception (assert)+#endif import qualified Data.ByteString.Internal as B  data S = S0@@ -52,7 +57,7 @@        | S3 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8        | S4 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 -data T = T {-# UNPACK #-} !ByteString {-# UNPACK #-} !S {-# UNPACK #-} !Int+data T = T !ByteString !S {-# UNPACK #-} !Int  -- | /O(n)/ Convert a lazy 'ByteString' into a 'Stream Char', using -- UTF-8 encoding.@@ -66,7 +71,7 @@           Yield (U8.chr2 a b)     (T bs S0 (i+2))       | i + 2 < len && U8.validate3 a b c =           Yield (U8.chr3 a b c)   (T bs S0 (i+3))-      | i + 4 < len && U8.validate4 a b c d =+      | i + 3 < len && U8.validate4 a b c d =           Yield (U8.chr4 a b c d) (T bs S0 (i+4))       where len = B.length ps             a = B.unsafeIndex ps i@@ -96,6 +101,174 @@     consume st             = decodeError "streamUtf8" "UTF-8" onErr Nothing st {-# INLINE [0] streamUtf8 #-} +-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little+-- endian UTF-16 encoding.+streamUtf16LE :: OnDecodeError -> ByteString -> Stream Char+streamUtf16LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize+  where+    next (T bs@(Chunk ps _) S0 i)+      | i + 1 < len && U16.validate1 x1 =+          Yield (unsafeChr x1)         (T bs S0 (i+2))+      | i + 3 < len && U16.validate2 x1 x2 =+          Yield (U16.chr2 x1 x2)       (T bs S0 (i+4))+      where len = B.length ps+            x1   = c (idx  i)      (idx (i + 1))+            x2   = c (idx (i + 2)) (idx (i + 3))+            c w1 w2 = w1 + (w2 `shiftL` 8)+            idx = fromIntegral . B.unsafeIndex ps :: Int -> Word16+    next st@(T bs s i) =+      case s of+        S2 w1 w2       | U16.validate1 (c w1 w2)           ->+          Yield (unsafeChr (c w1 w2))   es+        S4 w1 w2 w3 w4 | U16.validate2 (c w1 w2) (c w3 w4) ->+          Yield (U16.chr2 (c w1 w2) (c w3 w4)) es+        _ -> consume st+       where es = T bs S0 i+             c :: Word8 -> Word8 -> Word16+             c w1 w2 = fromIntegral w1 + (fromIntegral w2 `shiftL` 8)+    consume (T bs@(Chunk ps rest) s i)+        | i >= B.length ps = consume (T rest s 0)+        | otherwise =+      case s of+        S0             -> next (T bs (S1 x)          (i+1))+        S1 w1          -> next (T bs (S2 w1 x)       (i+1))+        S2 w1 w2       -> next (T bs (S3 w1 w2 x)    (i+1))+        S3 w1 w2 w3    -> next (T bs (S4 w1 w2 w3 x) (i+1))+        S4 w1 w2 w3 w4 -> decodeError "streamUtf16LE" "UTF-16LE" onErr (Just w1)+                           (T bs (S3 w2 w3 w4)       (i+1))+        where x = B.unsafeIndex ps i+    consume (T Empty S0 _) = Done+    consume st             = decodeError "streamUtf16LE" "UTF-16LE" onErr Nothing st+{-# INLINE [0] streamUtf16LE #-}++-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big+-- endian UTF-16 encoding.+streamUtf16BE :: OnDecodeError -> ByteString -> Stream Char+streamUtf16BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize+  where+    next (T bs@(Chunk ps _) S0 i)+      | i + 1 < len && U16.validate1 x1 =+          Yield (unsafeChr x1)         (T bs S0 (i+2))+      | i + 3 < len && U16.validate2 x1 x2 =+          Yield (U16.chr2 x1 x2)       (T bs S0 (i+4))+      where len = B.length ps+            x1   = c (idx  i)      (idx (i + 1))+            x2   = c (idx (i + 2)) (idx (i + 3))+            c w1 w2 = (w1 `shiftL` 8) + w2+            idx = fromIntegral . B.unsafeIndex ps :: Int -> Word16+    next st@(T bs s i) =+      case s of+        S2 w1 w2       | U16.validate1 (c w1 w2)           ->+          Yield (unsafeChr (c w1 w2))   es+        S4 w1 w2 w3 w4 | U16.validate2 (c w1 w2) (c w3 w4) ->+          Yield (U16.chr2 (c w1 w2) (c w3 w4)) es+        _ -> consume st+       where es = T bs S0 i+             c :: Word8 -> Word8 -> Word16+             c w1 w2 = (fromIntegral w1 `shiftL` 8) + fromIntegral w2+    consume (T bs@(Chunk ps rest) s i)+        | i >= B.length ps = consume (T rest s 0)+        | otherwise =+      case s of+        S0             -> next (T bs (S1 x)          (i+1))+        S1 w1          -> next (T bs (S2 w1 x)       (i+1))+        S2 w1 w2       -> next (T bs (S3 w1 w2 x)    (i+1))+        S3 w1 w2 w3    -> next (T bs (S4 w1 w2 w3 x) (i+1))+        S4 w1 w2 w3 w4 -> decodeError "streamUtf16BE" "UTF-16BE" onErr (Just w1)+                           (T bs (S3 w2 w3 w4)       (i+1))+        where x = B.unsafeIndex ps i+    consume (T Empty S0 _) = Done+    consume st             = decodeError "streamUtf16BE" "UTF-16BE" onErr Nothing st+{-# INLINE [0] streamUtf16BE #-}++-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big+-- endian UTF-32 encoding.+streamUtf32BE :: OnDecodeError -> ByteString -> Stream Char+streamUtf32BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize+  where+    next (T bs@(Chunk ps _) S0 i)+      | i + 3 < len && U32.validate x =+          Yield (unsafeChr32 x)       (T bs S0 (i+4))+      where len = B.length ps+            x = shiftL x1 24 + shiftL x2 16 + shiftL x3 8 + x4+            x1    = idx i+            x2    = idx (i+1)+            x3    = idx (i+2)+            x4    = idx (i+3)+            idx = fromIntegral . B.unsafeIndex ps :: Int -> Word32+    next st@(T bs s i) =+      case s of+        S4 w1 w2 w3 w4 | U32.validate (c w1 w2 w3 w4) ->+          Yield (unsafeChr32 (c w1 w2 w3 w4)) es+        _ -> consume st+       where es = T bs S0 i+             c :: Word8 -> Word8 -> Word8 -> Word8 -> Word32+             c w1 w2 w3 w4 = shifted+              where+               shifted = shiftL x1 24 + shiftL x2 16 + shiftL x3 8 + x4+               x1 = fromIntegral w1+               x2 = fromIntegral w2+               x3 = fromIntegral w3+               x4 = fromIntegral w4+    consume (T bs@(Chunk ps rest) s i)+        | i >= B.length ps = consume (T rest s 0)+        | otherwise =+      case s of+        S0             -> next (T bs (S1 x)          (i+1))+        S1 w1          -> next (T bs (S2 w1 x)       (i+1))+        S2 w1 w2       -> next (T bs (S3 w1 w2 x)    (i+1))+        S3 w1 w2 w3    -> next (T bs (S4 w1 w2 w3 x) (i+1))+        S4 w1 w2 w3 w4 -> decodeError "streamUtf32BE" "UTF-32BE" onErr (Just w1)+                           (T bs (S3 w2 w3 w4)       (i+1))+        where x = B.unsafeIndex ps i+    consume (T Empty S0 _) = Done+    consume st             = decodeError "streamUtf32BE" "UTF-32BE" onErr Nothing st+{-# INLINE [0] streamUtf32BE #-}++-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little+-- endian UTF-32 encoding.+streamUtf32LE :: OnDecodeError -> ByteString -> Stream Char+streamUtf32LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize+  where+    next (T bs@(Chunk ps _) S0 i)+      | i + 3 < len && U32.validate x =+          Yield (unsafeChr32 x)       (T bs S0 (i+4))+      where len = B.length ps+            x = shiftL x4 24 + shiftL x3 16 + shiftL x2 8 + x1+            x1    = idx i+            x2    = idx (i+1)+            x3    = idx (i+2)+            x4    = idx (i+3)+            idx = fromIntegral . B.unsafeIndex ps :: Int -> Word32+    next st@(T bs s i) =+      case s of+        S4 w1 w2 w3 w4 | U32.validate (c w1 w2 w3 w4) ->+          Yield (unsafeChr32 (c w1 w2 w3 w4)) es+        _ -> consume st+       where es = T bs S0 i+             c :: Word8 -> Word8 -> Word8 -> Word8 -> Word32+             c w1 w2 w3 w4 = shifted+              where+               shifted = shiftL x4 24 + shiftL x3 16 + shiftL x2 8 + x1+               x1 = fromIntegral w1+               x2 = fromIntegral w2+               x3 = fromIntegral w3+               x4 = fromIntegral w4+    consume (T bs@(Chunk ps rest) s i)+        | i >= B.length ps = consume (T rest s 0)+        | otherwise =+      case s of+        S0             -> next (T bs (S1 x)          (i+1))+        S1 w1          -> next (T bs (S2 w1 x)       (i+1))+        S2 w1 w2       -> next (T bs (S3 w1 w2 x)    (i+1))+        S3 w1 w2 w3    -> next (T bs (S4 w1 w2 w3 x) (i+1))+        S4 w1 w2 w3 w4 -> decodeError "streamUtf32LE" "UTF-32LE" onErr (Just w1)+                           (T bs (S3 w2 w3 w4)       (i+1))+        where x = B.unsafeIndex ps i+    consume (T Empty S0 _) = Done+    consume st             = decodeError "streamUtf32LE" "UTF-32LE" onErr Nothing st+{-# INLINE [0] streamUtf32LE #-}+ -- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'. unstreamChunks :: Int -> Stream Word8 -> ByteString unstreamChunks chunkSize (Stream next s0 len0) = chunk s0 (upperBound 4 len0)@@ -123,7 +296,11 @@               loop n' (off+1) s fp'             trimUp fp off = B.PS fp 0 off             copy0 :: ForeignPtr Word8 -> Int -> Int -> IO (ForeignPtr Word8)-            copy0 !src !srcLen !destLen = assert (srcLen <= destLen) $ do+            copy0 !src !srcLen !destLen =+#if defined(ASSERTS)+              assert (srcLen <= destLen) $+#endif+              do                 dest <- mallocByteString destLen                 withForeignPtr src  $ \src'  ->                     withForeignPtr dest $ \dest' ->

@@ -1,6 +1,7 @@+{-# LANGUAGE BangPatterns #-} -- | -- Module      : Data.Text.Lazy.Fusion--- Copyright   : (c) Bryan O'Sullivan 2009+-- Copyright   : (c) 2009, 2010 Bryan O'Sullivan -- -- License     : BSD-style -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,@@ -29,7 +30,8 @@ import qualified Data.Text.Internal as I import qualified Data.Text.Array as A import Data.Text.UnsafeChar (unsafeWrite)-import Data.Text.Unsafe (iter)+import Data.Text.UnsafeShift (shiftL)+import Data.Text.Unsafe (Iter(..), iter) import Data.Int (Int64)  default(Int64)@@ -42,7 +44,7 @@     next (txt@(Chunk t@(I.Text _ _ len) ts) :*: i)         | i >= len  = next (ts :*: 0)         | otherwise = Yield c (txt :*: i+d)-        where (c,d) = iter t i+        where Iter c d = iter t i {-# INLINE [0] stream #-}  -- | /O(n)/ Convert a 'Stream Char' into a 'Text', using the given@@ -58,21 +60,21 @@                 Yield x s' -> I.Text arr 0 len `chunk` outer s''                   where (arr,(s'',len)) = A.run2 fill                         fill = do a <- A.unsafeNew unknownLength-                                  i <- unsafeWrite a 0 x-                                  inner a unknownLength s' i+                                  unsafeWrite a 0 x >>= inner a unknownLength s'                         unknownLength = 4-    inner marr len s i+    inner marr len s !i         | i + 1 >= chunkSize = return (marr, (s,i))         | i + 1 >= len       = do-            let newLen = min (len * 2) chunkSize+            let newLen = min (len `shiftL` 1) chunkSize             marr' <- A.unsafeNew newLen-            A.copy marr marr'+            A.copyM marr' 0 marr 0 len             inner marr' newLen s i         | otherwise =             case next s of               Done        -> return (marr,(s,i))               Skip s'     -> inner marr len s' i-              Yield x s'  -> unsafeWrite marr i x >>= inner marr len s'+              Yield x s'  -> do d <- unsafeWrite marr i x+                                inner marr len s' (i+d) {-# INLINE [0] unstreamChunks #-}  -- | /O(n)/ Convert a 'Stream Char' into a 'Text', using@@ -89,9 +91,9 @@ {-# RULES "LAZY STREAM stream/unstream fusion" forall s.     stream (unstream s) = s #-} --- | /O(n)/ Like 'unfoldr', 'unfoldrN64' builds a stream from a seed+-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a stream from a seed -- value. However, the length of the result is limited by the--- first argument to 'unfoldrN64'. This function is more efficient than+-- first argument to 'unfoldrN'. This function is more efficient than -- 'unfoldr' when the length of the result is known. unfoldrN :: Int64 -> (a -> Maybe (Char,a)) -> a -> Stream Char unfoldrN n = S.unfoldrNI n

@@ -1,8 +1,8 @@ {-# LANGUAGE BangPatterns, CPP, RecordWildCards #-} -- | -- Module      : Data.Text.Lazy.IO--- Copyright   : (c) Bryan O'Sullivan 2009,---               (c) Simon Marlow 2009+-- Copyright   : (c) 2009, 2010 Bryan O'Sullivan,+--               (c) 2009 Simon Marlow -- License     : BSD-style -- Maintainer  : bos@serpentine.com -- Stability   : experimental@@ -44,6 +44,7 @@ import qualified Data.ByteString.Lazy.Char8 as L8 #else import Control.Exception (throw)+import Control.Monad (when) import Data.IORef (readIORef) import Data.Text.IO.Internal (hGetLineWith, readChunk) import Data.Text.Lazy.Internal (chunk, empty)@@ -52,6 +53,7 @@ import GHC.IO.Handle.Internals (augmentIOError, hClose_help,                                 wantReadableHandle, withHandle) import GHC.IO.Handle.Types (Handle__(..), HandleType(..))+import System.IO (BufferMode(..), hGetBuffering, hSetBuffering) import System.IO.Error (isEOFError) import System.IO.Unsafe (unsafeInterleaveIO) #endif@@ -76,10 +78,19 @@ #if __GLASGOW_HASKELL__ <= 610 hGetContents = fmap decodeUtf8 . L8.hGetContents #else-hGetContents h =-    wantReadableHandle "hGetContents" h $ \hh -> do-      ts <- lazyRead h-      return (hh{haType=SemiClosedHandle}, ts)+hGetContents h = do+  chooseGoodBuffering h+  wantReadableHandle "hGetContents" h $ \hh -> do+    ts <- lazyRead h+    return (hh{haType=SemiClosedHandle}, ts)++-- | Use a more efficient buffer size if we're reading in+-- block-buffered mode with the default buffer size.+chooseGoodBuffering :: Handle -> IO ()+chooseGoodBuffering h = do+  bufMode <- hGetBuffering h+  when (bufMode == BlockBuffering Nothing) $+    hSetBuffering h (BlockBuffering (Just 16384))  lazyRead :: Handle -> IO Text lazyRead h = unsafeInterleaveIO $

@@ -1,7 +1,7 @@ {-# LANGUAGE BangPatterns, DeriveDataTypeable #-} -- | -- Module      : Data.Text.Lazy.Internal--- Copyright   : (c) Bryan O'Sullivan 2009+-- Copyright   : (c) 2009, 2010 Bryan O'Sullivan -- -- License     : BSD-style -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,@@ -21,9 +21,12 @@     , foldrChunks     , foldlChunks     -- * Data type invariant and abstraction functions-    , invariant-    , checkInvariant++    -- $invariant+    , strictInvariant+    , lazyInvariant     , showStructure+     -- * Chunk allocation sizes     , defaultChunkSize     , smallChunkSize@@ -32,35 +35,43 @@  import qualified Data.Text.Internal as T import Data.Text ()+import Data.Text.UnsafeShift import Data.Typeable (Typeable)-import Data.Word (Word16) import Foreign.Storable (sizeOf)  data Text = Empty           | Chunk {-# UNPACK #-} !T.Text Text             deriving (Typeable) --- | The data type invariant: Every 'Text' is either 'Empty' or+-- $invariant+--+-- The data type invariant for lazy 'Text': Every 'Text' is either 'Empty' or -- consists of non-null 'T.Text's.  All functions must preserve this, -- and the QC properties must check this.-invariant :: Text -> Bool-invariant Empty                       = True-invariant (Chunk (T.Text _ _ len) cs) = len > 0 && invariant cs +-- | Check the invariant strictly.+strictInvariant :: Text -> Bool+strictInvariant Empty = True+strictInvariant x@(Chunk (T.Text _ _ len) cs)+    | len > 0   = strictInvariant cs+    | otherwise = error $ "Data.Text.Lazy: invariant violation: "+                  ++ showStructure x++-- | Check the invariant lazily.+lazyInvariant :: Text -> Text+lazyInvariant Empty = Empty+lazyInvariant x@(Chunk c@(T.Text _ _ len) cs)+    | len > 0   = Chunk c (lazyInvariant cs)+    | otherwise = error $ "Data.Text.Lazy: invariant violation: "+                  ++ showStructure x++-- | Display the internal structure of a lazy 'Text'. showStructure :: Text -> String showStructure Empty           = "Empty" showStructure (Chunk t Empty) = "Chunk " ++ show t ++ " Empty" showStructure (Chunk t ts)    =     "Chunk " ++ show t ++ " (" ++ showStructure ts ++ ")" --- | In a form that checks the invariant lazily.-checkInvariant :: Text -> Text-checkInvariant Empty = Empty-checkInvariant (Chunk c@(T.Text _ _ len) cs)-    | len > 0   = Chunk c (checkInvariant cs)-    | otherwise = error $ "Data.Text.Lazy: invariant violation: "-               ++ showStructure (Chunk c cs)- -- | Smart constructor for 'Chunk'. Guarantees the data type invariant. chunk :: T.Text -> Text -> Text {-# INLINE chunk #-}@@ -87,17 +98,17 @@         go !a (Chunk c cs) = go (f a c) cs {-# INLINE foldlChunks #-} --- | Currently set to 32k, less the memory management overhead.+-- | Currently set to 16 KiB, less the memory management overhead. defaultChunkSize :: Int-defaultChunkSize = 32 * k - chunkOverhead-   where k = 1024 `div` sizeOf (undefined :: Word16)+defaultChunkSize = 16384 - chunkOverhead {-# INLINE defaultChunkSize #-} --- | Currently set to 4k, less the memory management overhead.+-- | Currently set to 128 bytes, less the memory management overhead. smallChunkSize :: Int-smallChunkSize = 4 * k - chunkOverhead-   where k = 1024 `div` sizeOf (undefined :: Word16)+smallChunkSize = 128 - chunkOverhead+{-# INLINE smallChunkSize #-}  -- | The memory management overhead. Currently this is tuned for GHC only. chunkOverhead :: Int-chunkOverhead = 2 * sizeOf (undefined :: Int)+chunkOverhead = sizeOf (undefined :: Int) `shiftL` 1+{-# INLINE chunkOverhead #-}

@@ -2,7 +2,7 @@  -- | -- Module      : Data.Text.Lazy.Search--- Copyright   : (c) Bryan O'Sullivan 2009+-- Copyright   : (c) 2009, 2010 Bryan O'Sullivan -- -- License     : BSD-style -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,@@ -41,7 +41,7 @@         -> [Int64] indices needle@(Chunk n ns) _haystack@(Chunk k ks)     | nlen <= 0  = []-    | nlen == 1  = scanOne (nindex 0) 0 k ks+    | nlen == 1  = indicesOne (nindex 0) 0 k ks     | otherwise  = scan 0 0 k ks   where     scan !g !i x@(T.Text _ _ l) xs@@ -81,14 +81,6 @@                   skp' | c == z    = nlen - fromIntegral g - 2                        | otherwise = skp                   xlast = xlen - 1-    scanOne c i (T.Text oarr ooff olen) os = go 0-      where-        go h | h >= olen = case os of-                             Empty      -> []-                             Chunk y ys -> scanOne c (i+fromIntegral olen) y ys-             | on == c = i + fromIntegral h : go (h+1)-             | otherwise = go (h+1)-             where on = A.unsafeIndex oarr (ooff+h)     -- | Check whether an attempt to index into the haystack at the     -- given offset would fail.     lackingHay q = go 0@@ -103,7 +95,7 @@ -- the possibility that the caller might try to access one element -- past the end. index :: T.Text -> Text -> Int64 -> Word16-index (T.Text arr off len) xs i+index (T.Text arr off len) xs !i     | j < len   = A.unsafeIndex arr (off+j)     | otherwise = case xs of                     Empty@@ -113,6 +105,19 @@                         | otherwise -> emptyError "index"                     Chunk c cs -> index c cs (i-fromIntegral len)     where j = fromIntegral i++-- | A variant of 'indices' that scans linearly for a single 'Word16'.+indicesOne :: Word16 -> Int64 -> T.Text -> Text -> [Int64]+indicesOne c = chunk+  where+    chunk !i (T.Text oarr ooff olen) os = go 0+      where+        go h | h >= olen = case os of+                             Empty      -> []+                             Chunk y ys -> chunk (i+fromIntegral olen) y ys+             | on == c = i + fromIntegral h : go (h+1)+             | otherwise = go (h+1)+             where on = A.unsafeIndex oarr (ooff+h)  -- | The number of 'Word16' values in a 'Text'. wordLength :: Text -> Int64

@@ -40,7 +40,8 @@ import Data.Text.UnsafeShift (shiftL)  -- | /O(n+m)/ Find the offsets of all non-overlapping indices of--- @needle@ within @haystack@.+-- @needle@ within @haystack@.  The offsets returned represent+-- locations in the low-level array. -- -- In (unlikely) bad cases, this algorithm's complexity degrades -- towards /O(n*m)/.@@ -57,6 +58,8 @@     z        = nindex nlast     nindex k = A.unsafeIndex narr (noff+k)     hindex k = A.unsafeIndex harr (hoff+k)+    hindex' k | k == hlen  = 0+              | otherwise = A.unsafeIndex harr (hoff+k)     (mask :: Word64) :*: skip  = buildTable 0 0 (nlen-2)     buildTable !i !msk !skp         | i >= nlast           = (msk .|. swizzle z) :*: skp@@ -77,7 +80,7 @@               delta | nextInPattern = nlen + 1                     | c == z        = skip + 1                     | otherwise     = 1-              nextInPattern         = mask .&. swizzle (hindex (i+nlen)) == 0+              nextInPattern         = mask .&. swizzle (hindex' (i+nlen)) == 0     scanOne c = loop 0         where loop !i | i >= hlen     = []                       | hindex i == c = i : loop (i+1)

@@ -1,7 +1,7 @@ {-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} -- | -- Module      : Data.Text.Unsafe--- Copyright   : (c) Bryan O'Sullivan 2009+-- Copyright   : (c) 2009, 2010 Bryan O'Sullivan -- License     : BSD-style -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com, --               duncan@haskell.org@@ -14,14 +14,18 @@     (       inlineInterleaveST     , inlinePerformIO+    , Iter(..)     , iter     , iter_     , reverseIter     , unsafeHead     , unsafeTail+    , lengthWord16     ) where      +#if defined(ASSERTS) import Control.Exception (assert)+#endif import Data.Text.Encoding.Utf16 (chr2) import Data.Text.Internal (Text(..)) import Data.Text.UnsafeChar (unsafeChr)@@ -40,11 +44,11 @@ -- omits the check for the empty case, so there is an obligation on -- the programmer to provide a proof that the 'Text' is non-empty. unsafeHead :: Text -> Char-unsafeHead (Text arr off len)+unsafeHead (Text arr off _len)     | m < 0xD800 || m > 0xDBFF = unsafeChr m     | otherwise                = chr2 m n-    where m = assert (len > 0) $ A.unsafeIndex arr off-          n = assert (len > 1) $ A.unsafeIndex arr (off+1)+    where m = A.unsafeIndex arr off+          n = A.unsafeIndex arr (off+1) {-# INLINE unsafeHead #-}  -- | /O(1)/ A variant of 'tail' for non-empty 'Text'. 'unsafeHead'@@ -52,42 +56,47 @@ -- the programmer to provide a proof that the 'Text' is non-empty. unsafeTail :: Text -> Text unsafeTail t@(Text arr off len) =-    assert (d <= len) $ Text arr (off+d) (len-d)+#if defined(ASSERTS)+    assert (d <= len) $+#endif+    Text arr (off+d) (len-d)   where d = iter_ t 0 {-# INLINE unsafeTail #-} --- | /O(1)/ Iterate one step forwards through a UTF-16 array,--- returning the current character and the delta to add to give the--- next offset to iterate at.-iter :: Text -> Int -> (Char,Int)-iter (Text arr off len) i-    | m < 0xD800 || m > 0xDBFF = (unsafeChr m, 1)-    | otherwise                = (chr2 m n,    2)-  where m = assert (i < len)     $ A.unsafeIndex arr j-        n = assert (i + 1 < len) $ A.unsafeIndex arr k-        j = assert (i >= 0)      $ off + i-        k =                        j + 1+data Iter = Iter {-# UNPACK #-} !Char {-# UNPACK #-} !Int++-- | /O(1)/ Iterate (unsafely) one step forwards through a UTF-16+-- array, returning the current character and the delta to add to give+-- the next offset to iterate at.+iter :: Text -> Int -> Iter+iter (Text arr off _len) i+    | m < 0xD800 || m > 0xDBFF = Iter (unsafeChr m) 1+    | otherwise                = Iter (chr2 m n) 2+  where m = A.unsafeIndex arr j+        n = A.unsafeIndex arr k+        j = off + i+        k = j + 1 {-# INLINE iter #-}  -- | /O(1)/ Iterate one step through a UTF-16 array, returning the -- delta to add to give the next offset to iterate at. iter_ :: Text -> Int -> Int-iter_ (Text arr off len) i | m < 0xD800 || m > 0xDBFF = 1-                           | otherwise                = 2-  where m = assert (i >= 0 && i < len) $ A.unsafeIndex arr (off+i)+iter_ (Text arr off _len) i | m < 0xD800 || m > 0xDBFF = 1+                            | otherwise                = 2+  where m = A.unsafeIndex arr (off+i) {-# INLINE iter_ #-}  -- | /O(1)/ Iterate one step backwards through a UTF-16 array, -- returning the current character and the delta to add (i.e. a -- negative number) to give the next offset to iterate at. reverseIter :: Text -> Int -> (Char,Int)-reverseIter (Text arr off len) i+reverseIter (Text arr off _len) i     | m < 0xDC00 || m > 0xDFFF = (unsafeChr m, -1)     | otherwise                = (chr2 n m,    -2)-  where m = assert (i < len)    $ A.unsafeIndex arr j-        n = assert (i - 1 >= 0) $ A.unsafeIndex arr k-        j = assert (i >= 0)     $ off + i-        k =                       j - 1+  where m = A.unsafeIndex arr j+        n = A.unsafeIndex arr k+        j = off + i+        k = j - 1 {-# INLINE reverseIter #-}  -- | Just like unsafePerformIO, but we inline it. Big performance gains as@@ -116,3 +125,10 @@ inlineInterleaveST (ST m) = ST $ \ s ->     let r = case m s of (# _, res #) -> res in (# s, r #) {-# INLINE inlineInterleaveST #-}++-- | /O(1)/ Return the length of a 'Text' in units of 'Word16'.  This+-- is useful for sizing a target array appropriately before using+-- 'unsafeCopyToPtr'.+lengthWord16 :: Text -> Int+lengthWord16 (Text _arr _off len) = len+{-# INLINE lengthWord16 #-}

@@ -1,10 +1,10 @@-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE CPP, MagicHash #-}  -- | -- Module      : Data.Text.UnsafeChar--- Copyright   : (c) Tom Harper 2008-2009,---               (c) Bryan O'Sullivan 2009,---               (c) Duncan Coutts 2009+-- Copyright   : (c) 2008, 2009 Tom Harper,+--               (c) 2009, 2010 Bryan O'Sullivan,+--               (c) 2009 Duncan Coutts -- -- License     : BSD-style -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,@@ -15,22 +15,28 @@ -- Fast character manipulation functions. module Data.Text.UnsafeChar     (-      unsafeChr+      ord+    , unsafeChr     , unsafeChr8     , unsafeChr32     , unsafeWrite     -- , unsafeWriteRev     ) where +#ifdef ASSERTS import Control.Exception (assert)+#endif import Control.Monad.ST (ST) import Data.Bits ((.&.))-import Data.Char (ord) import Data.Text.UnsafeShift (shiftR)-import GHC.Exts (Char(..), chr#, word2Int#)+import GHC.Exts (Char(..), Int(..), chr#, ord#, word2Int#) import GHC.Word (Word8(..), Word16(..), Word32(..)) import qualified Data.Text.Array as A +ord :: Char -> Int+ord (C# c#) = I# (ord# c#)+{-# INLINE ord #-}+ unsafeChr :: Word16 -> Char unsafeChr (W16# w#) = C# (chr# (word2Int# w#)) {-# INLINE unsafeChr #-}@@ -43,17 +49,23 @@ unsafeChr32 (W32# w#) = C# (chr# (word2Int# w#)) {-# INLINE unsafeChr32 #-} -unsafeWrite :: A.MArray s Word16 -> Int -> Char -> ST s Int+-- | Write a character into the array at the given offset.  Returns+-- the number of 'Word16's written.+unsafeWrite :: A.MArray s -> Int -> Char -> ST s Int unsafeWrite marr i c     | n < 0x10000 = do-        assert (i >= 0) . assert (i < A.length marr) $-          A.unsafeWrite marr i (fromIntegral n)-        return (i+1)+#if defined(ASSERTS)+        assert (i >= 0) . assert (i < A.length marr) $ return ()+#endif+        A.unsafeWrite marr i (fromIntegral n)+        return 1     | otherwise = do-        assert (i >= 0) . assert (i < A.length marr - 1) $-          A.unsafeWrite marr i lo+#if defined(ASSERTS)+        assert (i >= 0) . assert (i < A.length marr - 1) $ return ()+#endif+        A.unsafeWrite marr i lo         A.unsafeWrite marr (i+1) hi-        return (i+2)+        return 2     where n = ord c           m = n - 0x10000           lo = fromIntegral $ (m `shiftR` 10) + 0xD800

@@ -8,7 +8,7 @@ import Criterion.Main import Data.Char import Data.Monoid (mappend, mempty)-import qualified Codec.Binary.UTF8.Generic as UTF8+import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.Text as TS import qualified Data.Text.IO as TS import qualified Data.Text.Lazy as TL@@ -113,6 +113,13 @@       , bench "bs" $ nf (BS.drop (bsa_len `div` 3)) bsa       , bench "bl" $ nf (BL.drop (bla_len `div` 3)) bla       , bench "l" $ nf (L.drop (la_len `div` 3)) la+      ],+      bgroup "encode" [+        bench "ts" $ nf TS.encodeUtf8 tsa+      , bench "tl" $ nf TL.encodeUtf8 tla+      , bench "bs" $ nf BS.pack la+      , bench "bl" $ nf BL.pack la+      , bench "l" $ nf UTF8.fromString la       ],       bgroup "filter" [         bench "ts" $ nf (TS.filter p0) tsa

@@ -1,11 +1,13 @@ version := $(shell awk '/^version:/{print $$2}' ../text.cabal) ghc := ghc ghc-opt-flags = -O0-ghc-base-flags := -funbox-strict-fields -package criterion \+ghc-base-flags := -funbox-strict-fields -hide-all-packages \+	-package base -package mtl -package random -package directory \+	-package criterion -package deepseq -DASSERTS -DHAVE_DEEPSEQ \ 	-package bytestring -ignore-package text \ 	-fno-ignore-asserts-ghc-test-flags := -package QuickCheck -package test-framework \-	-package test-framework-quickcheck -package test-framework-hunit \+ghc-test-flags := -package QuickCheck -package test-framework -package deepseq \+	-package test-framework-quickcheck2 -package test-framework-hunit \ 	-package HUnit ghc-base-flags += -Wall -fno-warn-orphans -fno-warn-missing-signatures ghc-flags := $(ghc-base-flags) -i../dist/build -package-name text-$(version)@@ -30,36 +32,50 @@ 	cd .. && cabal build endif -Properties.o qc qc-hpc: ghc-flags += $(ghc-test-flags)-Properties.o: QuickCheckUtils.o SlowFunctions.o+Properties.o Regressions.o qc qc-hpc: ghc-flags += $(ghc-test-flags)+Properties.o: QuickCheckUtils.o SlowFunctions.o TestUtils.o  QuickCheckUtils.o: $(lib) -qc: Properties.o QuickCheckUtils.o SlowFunctions.o+qc: Properties.o QuickCheckUtils.o SlowFunctions.o TestUtils.o 	$(ghc) $(ghc-flags) -threaded -o $@ $^ $(lib)  sb: SearchBench.o SlowFunctions.o 	$(ghc) $(ghc-flags) -threaded -o $@ $^ $(lib) -qc-hpc: Properties.hs QuickCheckUtils.hs $(lib-srcs:%=../%)+qc-hpc: Properties.hs QuickCheckUtils.hs SlowFunctions.hs TestUtils.hs $(lib-srcs:%=../%) 	-mkdir -p hpcdir 	@rm -f $@.tix-	$(ghc) $(ghc-hpc-flags) $(ghc-opt-flags) -ihpcdir \+	$(ghc) $(ghc-hpc-flags) $(ghc-test-flags) $(ghc-opt-flags) -ihpcdir \ 	  --make -threaded -o $@ $< -regressions: Regressions.o-	$(ghc) $(ghc-test-flags) -o $@ $^ $(lib)+stdio-hpc: StdioCoverage.hs $(lib-srcs:%=../%)+	-mkdir -p hpcdir+	@rm -f $@.tix+	$(ghc) $(ghc-hpc-flags) $(ghc-test-flags) $(ghc-opt-flags) -ihpcdir \+	  --make -threaded -o $@ $< -coverage: qc-hpc-html/hpc_index.html+coverage: coverage-html/hpc_index.html -qc-hpc-html/hpc_index.html: qc-hpc-	./qc-hpc -a 100 +RTS -N2-	hpc markup qc-hpc --exclude=Main --exclude=Properties \-	  --exclude=Data.Text.Fusion.CaseMapping \+coverage-html/hpc_index.html: qc-hpc+	@rm -f qc-hpc.tix stdio-hpc.tix coverage.tix+	./qc-hpc -a 100 +RTS -N+	bash ./cover-stdio.sh+	hpc combine --output=coverage.tix --exclude=Main \+	  qc-hpc.tix stdio-hpc.tix+	hpc markup coverage --exclude=Main --exclude=Properties --exclude=Main \+	  --exclude=Data.Text.Fusion.CaseMapping --exclude StdioCoverage \+	  --exclude=SlowFunctions --exclude=TestUtils \ 	  --exclude=QuickCheckUtils --srcdir=.. --srcdir=. --destdir=$(dir $@)+	@echo xdg-open $@ +Regressions.o: TestUtils.o++regressions: Regressions.o TestUtils.o+	$(ghc) $(ghc-test-flags) -o $@ $^ $(lib)+ Benchmarks.o: ghc-opt-flags = -O-bm Benchmarks.o: ghc-flags += -hide-package transformers -package utf8-string+bm Benchmarks.o: ghc-flags += -package utf8-string bm: Benchmarks.o 	$(ghc) $(ghc-flags) -o $@ $^ $(lib) @@ -78,4 +94,4 @@ 	curl -O http://projects.haskell.org/text/text-testdata.tar.bz2  clean:-	-rm -rf *.o *.hi *.tix bm qc qc-hpc hpcdir .hpc qc-hpc-html+	-rm -rf *.o *.hi *.tix bm qc qc-hpc stdio-hpc hpcdir .hpc coverage-html

@@ -2,7 +2,8 @@              ScopedTypeVariables, TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-enable-rewrite-rules #-} -import Test.QuickCheck hiding (evaluate)+import Test.QuickCheck+import Test.QuickCheck.Monadic import Text.Show.Functions ()  import qualified Data.Bits as Bits (shiftL, shiftR)@@ -11,12 +12,18 @@ import Data.String (fromString) import Debug.Trace (trace) import Control.Arrow ((***), second)+import Control.DeepSeq import Data.Word (Word8, Word16, Word32) import qualified Data.Text as T+import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.IO as TL+import qualified Data.Text.Lazy.Internal as TL import qualified Data.Text.Lazy.Builder as TB import qualified Data.Text.Encoding as E-import Control.Exception (SomeException, evaluate, try)+import Data.Text.Encoding.Error+import Control.Exception (SomeException, bracket, catch, evaluate, try)+import Data.Text.Foreign import qualified Data.Text.Fusion as S import qualified Data.Text.Fusion.Common as S import Data.Text.Fusion.Size@@ -24,15 +31,17 @@ import qualified Data.Text.Lazy.Fusion as SL import qualified Data.Text.UnsafeShift as U import qualified Data.List as L-import Prelude hiding (replicate)+import Prelude hiding (catch, replicate)+import System.IO import System.IO.Unsafe (unsafePerformIO) import Test.Framework (defaultMain, testGroup)-import Test.Framework.Providers.QuickCheck (testProperty)+import Test.Framework.Providers.QuickCheck2 (testProperty) import Data.Text.Search (indices) import qualified Data.Text.Lazy.Search as S (indices) import qualified SlowFunctions as Slow -import QuickCheckUtils (NotEmpty(..), small)+import QuickCheckUtils (NotEmpty(..), genUnicode, small, unsquare)+import TestUtils (withRedirect, withTempFile)  -- Ensure that two potentially bottom values (in the sense of crashing -- for some inputs, not looping infinitely) either both crash, or both@@ -59,16 +68,48 @@ tl_unstreamChunks x = f 11 x == f 1000 x     where f n = SL.unstreamChunks n . S.streamList tl_chunk_unchunk    = (TL.fromChunks . TL.toChunks) `eq` id+tl_from_to_strict   = (TL.fromStrict . TL.toStrict) `eq` id -t_ascii t           = E.decodeASCII (E.encodeUtf8 a) == a-    where a              = T.map (\c -> chr (ord c `mod` 128)) t-t_utf8              = (E.decodeUtf8 . E.encodeUtf8) `eq` id-tl_utf8             = (EL.decodeUtf8 . EL.encodeUtf8) `eq` id-t_utf16LE           = (E.decodeUtf16LE . E.encodeUtf16LE) `eq` id-t_utf16BE           = (E.decodeUtf16BE . E.encodeUtf16BE) `eq` id-t_utf32LE           = (E.decodeUtf32LE . E.encodeUtf32LE) `eq` id-t_utf32BE           = (E.decodeUtf32BE . E.encodeUtf32BE) `eq` id+t_ascii t    = E.decodeASCII (E.encodeUtf8 a) == a+    where a  = T.map (\c -> chr (ord c `mod` 128)) t+tl_ascii t   = EL.decodeASCII (EL.encodeUtf8 a) == a+    where a  = TL.map (\c -> chr (ord c `mod` 128)) t+t_utf8       = forAll genUnicode $ (E.decodeUtf8 . E.encodeUtf8) `eq` id+tl_utf8      = forAll genUnicode $ (EL.decodeUtf8 . EL.encodeUtf8) `eq` id+t_utf16LE    = forAll genUnicode $ (E.decodeUtf16LE . E.encodeUtf16LE) `eq` id+tl_utf16LE   = forAll genUnicode $ (EL.decodeUtf16LE . EL.encodeUtf16LE) `eq` id+t_utf16BE    = forAll genUnicode $ (E.decodeUtf16BE . E.encodeUtf16BE) `eq` id+tl_utf16BE   = forAll genUnicode $ (EL.decodeUtf16BE . EL.encodeUtf16BE) `eq` id+t_utf32LE    = forAll genUnicode $ (E.decodeUtf32LE . E.encodeUtf32LE) `eq` id+tl_utf32LE   = forAll genUnicode $ (EL.decodeUtf32LE . EL.encodeUtf32LE) `eq` id+t_utf32BE    = forAll genUnicode $ (E.decodeUtf32BE . E.encodeUtf32BE) `eq` id+tl_utf32BE   = forAll genUnicode $ (EL.decodeUtf32BE . EL.encodeUtf32BE) `eq` id +data DecodeErr = DE String OnDecodeError++instance Show DecodeErr where+    show (DE d _) = "DE " ++ d++instance CoArbitrary Word8 where+    coarbitrary = coarbitraryIntegral++instance Arbitrary DecodeErr where+    arbitrary = oneof [ return $ DE "lenient" lenientDecode+                      , return $ DE "ignore" ignore+                      , return $ DE "strict" strictDecode+                      , DE "replace" `fmap` arbitrary ]++-- This is a poor attempt to ensure that the error handling paths on+-- decode are exercised in some way.  Proper testing would be rather+-- more involved.+t_utf8_err (DE _ de) bs = monadicIO $ do+  l <- run $ let len = T.length (E.decodeUtf8With de bs)+             in (len `seq` return (Right len)) `catch`+                (\(e::UnicodeException) -> return (Left e))+  case l of+    Left err -> assert $ length (show err) >= 0+    Right n  -> assert $ n >= 0+ class Stringy s where     packS    :: String -> s     unpackS  :: s -> String@@ -95,7 +136,8 @@     packSChunkSize k = SL.unstreamChunks k . S.streamList     packS    = TL.pack     unpackS  = TL.unpack-    splitAtS = TL.splitAt . fromIntegral+    splitAtS = ((TL.lazyInvariant *** TL.lazyInvariant) .) .+               TL.splitAt . fromIntegral  -- Do two functions give the same answer? eq :: (Eq a, Show a) => (t -> a) -> (t -> a) -> t -> Bool@@ -116,14 +158,9 @@           m | l == 0    = n             | otherwise = n `mod` l           n             = fromIntegral w-          eql d a b | a =^= b   = True-                    | otherwise = trace (d ++ ": " ++ show a ++ " /= " ++ show b) False---- For tests that have O(n^2) running times or input sizes, resize--- their inputs to the square root of the originals.-unsquare :: (Arbitrary a, Show a, Testable b) => (a -> b) -> Property-unsquare = forAll . sized $ \n -> resize (smallish n) arbitrary-    where smallish = round . (sqrt :: Double -> Double) . fromIntegral+          eql d a b+            | a =^= b   = True+            | otherwise = trace (d ++ ": " ++ show a ++ " /= " ++ show b) False  s_Eq s            = (s==)    `eq` ((S.streamList s==) . S.streamList)     where _types = s :: String@@ -145,8 +182,8 @@ tl_Show           = show     `eq` (show . TL.pack) t_mappend s       = mappend s`eqP` (unpackS . mappend (T.pack s)) tl_mappend s      = mappend s`eqP` (unpackS . mappend (TL.pack s))-t_mconcat         = unsquare (mconcat `eq` (unpackS . mconcat . L.map T.pack))-tl_mconcat        = unsquare (mconcat `eq` (unpackS . mconcat . L.map TL.pack))+t_mconcat         = mconcat `eq` (unpackS . mconcat . L.map T.pack)+tl_mconcat        = mconcat `eq` (unpackS . mconcat . L.map TL.pack) t_IsString        = fromString  `eqP` (T.unpack . fromString) tl_IsString       = fromString  `eqP` (TL.unpack . fromString) @@ -159,15 +196,18 @@ t_snoc x          = (++ [x]) `eqP` (unpackS . (flip T.snoc) x) tl_snoc x         = (++ [x]) `eqP` (unpackS . (flip TL.snoc) x) s_append s        = (s++)    `eqP` (unpackS . S.append (S.streamList s))-s_append_s s      = (s++)    `eqP` (unpackS . S.unstream . S.append (S.streamList s))-sf_append p s     = (L.filter p s++) `eqP` (unpackS . S.append (S.filter p $ S.streamList s))+s_append_s s      = (s++)    `eqP`+                    (unpackS . S.unstream . S.append (S.streamList s))+sf_append p s     = (L.filter p s++) `eqP`+                    (unpackS . S.append (S.filter p $ S.streamList s)) t_append s        = (s++)    `eqP` (unpackS . T.append (packS s))  uncons (x:xs) = Just (x,xs) uncons _      = Nothing  s_uncons          = uncons   `eqP` (fmap (second unpackS) . S.uncons)-sf_uncons p       = (uncons . L.filter p) `eqP` (fmap (second unpackS) . S.uncons . S.filter p)+sf_uncons p       = (uncons . L.filter p) `eqP`+                    (fmap (second unpackS) . S.uncons . S.filter p) t_uncons          = uncons   `eqP` (fmap (second unpackS) . T.uncons) tl_uncons         = uncons   `eqP` (fmap (second unpackS) . TL.uncons) s_head            = head   `eqP` S.head@@ -194,29 +234,39 @@ tl_null           = null   `eqP` TL.null s_length          = length `eqP` S.length sf_length p       = (length . L.filter p) `eqP` (S.length . S.filter p)+sl_length         = (fromIntegral . length) `eqP` SL.length t_length          = length `eqP` T.length-tl_length         = length `eqP` (fromIntegral . TL.length)+tl_length         = L.genericLength `eqP` TL.length+t_compareLength t = (compare (T.length t)) `eq` T.compareLength t+tl_compareLength t= (compare (TL.length t)) `eq` TL.compareLength t  s_map f           = map f  `eqP` (unpackS . S.map f) s_map_s f         = map f  `eqP` (unpackS . S.unstream . S.map f) sf_map p f        = (map f . L.filter p)  `eqP` (unpackS . S.map f . S.filter p) t_map f           = map f  `eqP` (unpackS . T.map f) tl_map f          = map f  `eqP` (unpackS . TL.map f)-t_intercalate c   = unsquare (L.intercalate c `eq` (unpackS . T.intercalate (packS c) . map packS))-tl_intercalate c  = unsquare (L.intercalate c `eq` (unpackS . TL.intercalate (TL.pack c) . map TL.pack))-s_intersperse c   = L.intersperse c `eqP` (unpackS . S.intersperse c)-s_intersperse_s c = L.intersperse c `eqP` (unpackS . S.unstream . S.intersperse c)-sf_intersperse p c= (L.intersperse c . L.filter p) `eqP` (unpackS . S.intersperse c . S.filter p)+t_intercalate c   = L.intercalate c `eq`+                    (unpackS . T.intercalate (packS c) . map packS)+tl_intercalate c  = L.intercalate c `eq`+                    (unpackS . TL.intercalate (TL.pack c) . map TL.pack)+s_intersperse c   = L.intersperse c `eqP`+                    (unpackS . S.intersperse c)+s_intersperse_s c = L.intersperse c `eqP`+                    (unpackS . S.unstream . S.intersperse c)+sf_intersperse p c= (L.intersperse c . L.filter p) `eqP`+                   (unpackS . S.intersperse c . S.filter p) t_intersperse c   = L.intersperse c `eqP` (unpackS . T.intersperse c) tl_intersperse c  = L.intersperse c `eqP` (unpackS . TL.intersperse c)-t_transpose       = unsquare (L.transpose `eq` (map unpackS . T.transpose . map packS))-tl_transpose      = unsquare (L.transpose `eq` (map unpackS . TL.transpose . map TL.pack))+t_transpose       = L.transpose `eq` (map unpackS . T.transpose . map packS)+tl_transpose      = L.transpose `eq` (map unpackS . TL.transpose . map TL.pack) t_reverse         = L.reverse `eqP` (unpackS . T.reverse) tl_reverse        = L.reverse `eqP` (unpackS . TL.reverse) t_reverse_short n = L.reverse `eqP` (unpackS . S.reverse . shorten n . S.stream) -t_replace s d     = (L.intercalate d . split s) `eqP` (unpackS . T.replace (T.pack s) (T.pack d))-tl_replace s d     = (L.intercalate d . split s) `eqP` (unpackS . TL.replace (TL.pack s) (TL.pack d))+t_replace s d     = (L.intercalate d . split s) `eqP`+                    (unpackS . T.replace (T.pack s) (T.pack d))+tl_replace s d     = (L.intercalate d . split s) `eqP`+                     (unpackS . TL.replace (TL.pack s) (TL.pack d))  split :: (Eq a) => [a] -> [a] -> [[a]] split pat src0@@ -249,25 +299,47 @@ tl_toUpper_upper t = p (TL.toUpper t) >= p t     where p = TL.length . TL.filter isUpper -justifyLeft k c s  = s ++ L.replicate (k - length s) c-justifyRight m n s = L.replicate (m - length s) n ++ s+justifyLeft k c xs  = xs ++ L.replicate (k - length xs) c+justifyRight m n xs = L.replicate (m - length xs) n ++ xs+center k c xs+    | len >= k  = xs+    | otherwise = L.replicate l c ++ xs ++ L.replicate r c+   where len = length xs+         d   = k - len+         r   = d `div` 2+         l   = d - r -s_justifyLeft k c = justifyLeft k c `eqP` (unpackS . S.justifyLeftI k c)-s_justifyLeft_s k c = justifyLeft k c `eqP` (unpackS . S.unstream . S.justifyLeftI k c)-sf_justifyLeft p k c =-    (justifyLeft k c . L.filter p) `eqP` (unpackS . S.justifyLeftI k c . S.filter p)-t_justifyLeft k c = justifyLeft k c `eqP` (unpackS . T.justifyLeft k c)-tl_justifyLeft k c = justifyLeft k c `eqP` (unpackS . TL.justifyLeft (fromIntegral k) c)-t_justifyRight k c = justifyRight k c `eqP` (unpackS . T.justifyRight k c)-tl_justifyRight k c = justifyRight k c `eqP` (unpackS . TL.justifyRight (fromIntegral k) c)+s_justifyLeft k c = justifyLeft j c `eqP` (unpackS . S.justifyLeftI j c)+    where j = fromIntegral (k :: Word8)+s_justifyLeft_s k c = justifyLeft j c `eqP`+                      (unpackS . S.unstream . S.justifyLeftI j c)+    where j = fromIntegral (k :: Word8)+sf_justifyLeft p k c = (justifyLeft j c . L.filter p) `eqP`+                       (unpackS . S.justifyLeftI j c . S.filter p)+    where j = fromIntegral (k :: Word8)+t_justifyLeft k c = justifyLeft j c `eqP` (unpackS . T.justifyLeft j c)+    where j = fromIntegral (k :: Word8)+tl_justifyLeft k c = justifyLeft j c `eqP`+                     (unpackS . TL.justifyLeft (fromIntegral j) c)+    where j = fromIntegral (k :: Word8)+t_justifyRight k c = justifyRight j c `eqP` (unpackS . T.justifyRight j c)+    where j = fromIntegral (k :: Word8)+tl_justifyRight k c = justifyRight j c `eqP`+                      (unpackS . TL.justifyRight (fromIntegral j) c)+    where j = fromIntegral (k :: Word8)+t_center k c = center j c `eqP` (unpackS . T.center j c)+    where j = fromIntegral (k :: Word8)+tl_center k c = center j c `eqP` (unpackS . TL.center (fromIntegral j) c)+    where j = fromIntegral (k :: Word8) -sf_foldl p f z     = (L.foldl f z . L.filter p)  `eqP` (S.foldl f z . S.filter p)+sf_foldl p f z    = (L.foldl f z . L.filter p) `eqP` (S.foldl f z . S.filter p)     where _types  = f :: Char -> Char -> Char t_foldl f z       = L.foldl f z  `eqP` (T.foldl f z)     where _types  = f :: Char -> Char -> Char tl_foldl f z      = L.foldl f z  `eqP` (TL.foldl f z)     where _types  = f :: Char -> Char -> Char-sf_foldl' p f z   = (L.foldl' f z . L.filter p) `eqP` (S.foldl' f z . S.filter p)+sf_foldl' p f z   = (L.foldl' f z . L.filter p) `eqP`+                    (S.foldl' f z . S.filter p)     where _types  = f :: Char -> Char -> Char t_foldl' f z      = L.foldl' f z `eqP` T.foldl' f z     where _types  = f :: Char -> Char -> Char@@ -289,13 +361,17 @@ t_foldr1 f        = L.foldr1 f   `eqP` T.foldr1 f tl_foldr1 f       = L.foldr1 f   `eqP` TL.foldr1 f -s_concat_s        = unsquare (L.concat `eq` (unpackS . S.unstream . S.concat . map packS))-sf_concat p       = unsquare ((L.concat . map (L.filter p)) `eq` (unpackS . S.concat . map (S.filter p . packS)))-t_concat          = unsquare (L.concat `eq` (unpackS . T.concat . map packS))-tl_concat         = unsquare (L.concat `eq` (unpackS . TL.concat . map TL.pack))-sf_concatMap p f  = unsquare ((L.concatMap f . L.filter p) `eqP` (unpackS . S.concatMap (packS . f) . S.filter p))-t_concatMap f     = unsquare (L.concatMap f `eqP` (unpackS . T.concatMap (packS . f)))-tl_concatMap f    = unsquare (L.concatMap f `eqP` (unpackS . TL.concatMap (TL.pack . f)))+s_concat_s        = L.concat `eq` (unpackS . S.unstream . S.concat . map packS)+sf_concat p       = (L.concat . map (L.filter p)) `eq`+                    (unpackS . S.concat . map (S.filter p . packS))+t_concat          = L.concat `eq` (unpackS . T.concat . map packS)+tl_concat         = L.concat `eq` (unpackS . TL.concat . map TL.pack)+sf_concatMap p f  = unsquare $ (L.concatMap f . L.filter p) `eqP`+                               (unpackS . S.concatMap (packS . f) . S.filter p)+t_concatMap f     = unsquare $+                    L.concatMap f `eqP` (unpackS . T.concatMap (packS . f))+tl_concatMap f    = unsquare $+                    L.concatMap f `eqP` (unpackS . TL.concatMap (TL.pack . f)) sf_any q p        = (L.any p . L.filter q) `eqP` (S.any p . S.filter q) t_any p           = L.any p       `eqP` T.any p tl_any p          = L.any p       `eqP` TL.any p@@ -309,7 +385,8 @@ t_minimum         = L.minimum     `eqP` T.minimum tl_minimum        = L.minimum     `eqP` TL.minimum -sf_scanl p f z    = (L.scanl f z . L.filter p) `eqP` (unpackS . S.scanl f z . S.filter p)+sf_scanl p f z    = (L.scanl f z . L.filter p) `eqP`+                    (unpackS . S.scanl f z . S.filter p) t_scanl f z       = L.scanl f z   `eqP` (unpackS . T.scanl f z) tl_scanl f z      = L.scanl f z   `eqP` (unpackS . TL.scanl f z) t_scanl1 f        = L.scanl1 f    `eqP` (unpackS . T.scanl1 f)@@ -319,30 +396,39 @@ t_scanr1 f        = L.scanr1 f    `eqP` (unpackS . T.scanr1 f) tl_scanr1 f       = L.scanr1 f    `eqP` (unpackS . TL.scanr1 f) -t_mapAccumL f z   = unsquare (L.mapAccumL f z `eqP` (second unpackS . T.mapAccumL f z))-    where _types = f :: Int -> Char -> (Int,Char)-tl_mapAccumL f z  = unsquare (L.mapAccumL f z `eqP` (second unpackS . TL.mapAccumL f z))-    where _types = f :: Int -> Char -> (Int,Char)-t_mapAccumR f z   = unsquare (L.mapAccumR f z `eqP` (second unpackS . T.mapAccumR f z))-    where _types = f :: Int -> Char -> (Int,Char)-tl_mapAccumR f z   = unsquare (L.mapAccumR f z `eqP` (second unpackS . TL.mapAccumR f z))-    where _types = f :: Int -> Char -> (Int,Char)+t_mapAccumL f z   = L.mapAccumL f z `eqP` (second unpackS . T.mapAccumL f z)+    where _types  = f :: Int -> Char -> (Int,Char)+tl_mapAccumL f z  = L.mapAccumL f z `eqP` (second unpackS . TL.mapAccumL f z)+    where _types  = f :: Int -> Char -> (Int,Char)+t_mapAccumR f z   = L.mapAccumR f z `eqP` (second unpackS . T.mapAccumR f z)+    where _types  = f :: Int -> Char -> (Int,Char)+tl_mapAccumR f z  = L.mapAccumR f z `eqP` (second unpackS . TL.mapAccumR f z)+    where _types  = f :: Int -> Char -> (Int,Char)  replicate n l = concat (L.replicate n l) -t_replicate n     = replicate n `eq` (unpackS . T.replicate n . packS)-tl_replicate n    = replicate n `eq` (unpackS . TL.replicate (fromIntegral n) . packS)+t_replicate n     = replicate m `eq` (unpackS . T.replicate m . packS)+    where m = fromIntegral (n :: Word8)+tl_replicate n    = replicate m `eq`+                    (unpackS . TL.replicate (fromIntegral m) . packS)+    where m = fromIntegral (n :: Word8)  unf :: Int -> Char -> Maybe (Char, Char) unf n c | fromEnum c * 100 > n = Nothing         | otherwise            = Just (c, succ c) -t_unfoldr n       = L.unfoldr (unf n) `eq` (unpackS . T.unfoldr (unf n))-tl_unfoldr n      = L.unfoldr (unf n) `eq` (unpackS . TL.unfoldr (unf n))-t_unfoldrN n m    = (L.take n . L.unfoldr (unf m)) `eq`-                         (unpackS . T.unfoldrN n (unf m))-tl_unfoldrN n m   = (L.take n . L.unfoldr (unf m)) `eq`-                         (unpackS . TL.unfoldrN (fromIntegral n) (unf m))+t_unfoldr n       = L.unfoldr (unf m) `eq` (unpackS . T.unfoldr (unf m))+    where m = fromIntegral (n :: Word16)+tl_unfoldr n      = L.unfoldr (unf m) `eq` (unpackS . TL.unfoldr (unf m))+    where m = fromIntegral (n :: Word16)+t_unfoldrN n m    = (L.take i . L.unfoldr (unf j)) `eq`+                         (unpackS . T.unfoldrN i (unf j))+    where i = fromIntegral (n :: Word16)+          j = fromIntegral (m :: Word16)+tl_unfoldrN n m   = (L.take i . L.unfoldr (unf j)) `eq`+                         (unpackS . TL.unfoldrN (fromIntegral i) (unf j))+    where i = fromIntegral (n :: Word16)+          j = fromIntegral (m :: Word16)  unpack2 :: (Stringy s) => (s,s) -> (String,String) unpack2 = unpackS *** unpackS@@ -350,33 +436,42 @@ s_take n          = L.take n      `eqP` (unpackS . S.take n) s_take_s m        = L.take n      `eqP` (unpackS . S.unstream . S.take n)   where n = small m-sf_take p n       = (L.take n . L.filter p) `eqP` (unpackS . S.take n . S.filter p)+sf_take p n       = (L.take n . L.filter p) `eqP`+                    (unpackS . S.take n . S.filter p) t_take n          = L.take n      `eqP` (unpackS . T.take n) tl_take n         = L.take n      `eqP` (unpackS . TL.take (fromIntegral n)) s_drop n          = L.drop n      `eqP` (unpackS . S.drop n) s_drop_s m        = L.drop n      `eqP` (unpackS . S.unstream . S.drop n)   where n = small m-sf_drop p n       = (L.drop n . L.filter p) `eqP` (unpackS . S.drop n . S.filter p)+sf_drop p n       = (L.drop n . L.filter p) `eqP`+                    (unpackS . S.drop n . S.filter p) t_drop n          = L.drop n      `eqP` (unpackS . T.drop n) tl_drop n         = L.drop n      `eqP` (unpackS . TL.drop (fromIntegral n)) s_take_drop m     = (L.take n . L.drop n) `eqP` (unpackS . S.take n . S.drop n)   where n = small m-s_take_drop_s m   = (L.take n . L.drop n) `eqP` (unpackS . S.unstream . S.take n . S.drop n)+s_take_drop_s m   = (L.take n . L.drop n) `eqP`+                    (unpackS . S.unstream . S.take n . S.drop n)   where n = small m s_takeWhile p     = L.takeWhile p `eqP` (unpackS . S.takeWhile p) s_takeWhile_s p   = L.takeWhile p `eqP` (unpackS . S.unstream . S.takeWhile p)-sf_takeWhile q p  = (L.takeWhile p . L.filter q) `eqP` (unpackS . S.takeWhile p . S.filter q)+sf_takeWhile q p  = (L.takeWhile p . L.filter q) `eqP`+                    (unpackS . S.takeWhile p . S.filter q) t_takeWhile p     = L.takeWhile p `eqP` (unpackS . T.takeWhile p) tl_takeWhile p    = L.takeWhile p `eqP` (unpackS . TL.takeWhile p) s_dropWhile p     = L.dropWhile p `eqP` (unpackS . S.dropWhile p) s_dropWhile_s p   = L.dropWhile p `eqP` (unpackS . S.unstream . S.dropWhile p)-sf_dropWhile q p  = (L.dropWhile p . L.filter q) `eqP` (unpackS . S.dropWhile p . S.filter q)+sf_dropWhile q p  = (L.dropWhile p . L.filter q) `eqP`+                    (unpackS . S.dropWhile p . S.filter q) t_dropWhile p     = L.dropWhile p `eqP` (unpackS . T.dropWhile p) tl_dropWhile p    = L.dropWhile p `eqP` (unpackS . S.dropWhile p)-t_dropWhileEnd p  = (L.reverse . L.dropWhile p . L.reverse) `eqP` (unpackS . T.dropWhileEnd p)-tl_dropWhileEnd p = (L.reverse . L.dropWhile p . L.reverse) `eqP` (unpackS . TL.dropWhileEnd p)-t_dropAround p    = (L.dropWhile p . L.reverse . L.dropWhile p . L.reverse) `eqP` (unpackS . T.dropAround p)-tl_dropAround p   = (L.dropWhile p . L.reverse . L.dropWhile p . L.reverse) `eqP` (unpackS . TL.dropAround p)+t_dropWhileEnd p  = (L.reverse . L.dropWhile p . L.reverse) `eqP`+                    (unpackS . T.dropWhileEnd p)+tl_dropWhileEnd p = (L.reverse . L.dropWhile p . L.reverse) `eqP`+                    (unpackS . TL.dropWhileEnd p)+t_dropAround p    = (L.dropWhile p . L.reverse . L.dropWhile p . L.reverse)+                    `eqP` (unpackS . T.dropAround p)+tl_dropAround p   = (L.dropWhile p . L.reverse . L.dropWhile p . L.reverse)+                    `eqP` (unpackS . TL.dropAround p) t_stripStart      = T.dropWhile isSpace `eq` T.stripStart tl_stripStart     = TL.dropWhile isSpace `eq` TL.stripStart t_stripEnd        = T.dropWhileEnd isSpace `eq` T.stripEnd@@ -398,6 +493,10 @@                                in T.null m || s `T.isPrefixOf` m tl_break_start (NotEmpty s) t = let (_,m) = TL.break s t                                 in TL.null m || s `TL.isPrefixOf` m+t_breakEnd_end (NotEmpty s) t = let (m,_) = T.breakEnd s t+                                in T.null m || s `T.isSuffixOf` m+tl_breakEnd_end (NotEmpty s) t = let (m,_) = TL.breakEnd s t+                                in TL.null m || s `TL.isSuffixOf` m t_breakBy p       = L.break p     `eqP` (unpack2 . T.breakBy p) tl_breakBy p      = L.break p     `eqP` (unpack2 . TL.breakBy p) t_group           = L.group       `eqP` (map unpackS . T.group)@@ -408,25 +507,29 @@ tl_inits          = L.inits       `eqP` (map unpackS . TL.inits) t_tails           = L.tails       `eqP` (map unpackS . T.tails) tl_tails          = L.tails       `eqP` (map unpackS . TL.tails)+t_findAppendId (NotEmpty s) = unsquare $ \ts ->+    let t = T.intercalate s ts+    in all (==t) $ map (uncurry T.append) (T.find s t)+tl_findAppendId (NotEmpty s) = unsquare $ \ts ->+    let t = TL.intercalate s ts+    in all (==t) $ map (uncurry TL.append) (TL.find s t)+t_findContains (NotEmpty s) = all (T.isPrefixOf s . snd) . T.find s .+                              T.intercalate s+tl_findContains (NotEmpty s) = all (TL.isPrefixOf s . snd) .+                               TL.find s . TL.intercalate s+sl_filterCount c  = (L.genericLength . L.filter (==c)) `eqP` SL.countChar c+t_findCount s     = (L.length . T.find s) `eq` T.count s+tl_findCount s    = (L.genericLength . TL.find s) `eq` TL.count s -t_findSplit s t         = (T.split s `eq` splitty) u-  where splitty v       = case T.find s v  of-                            (x,xs) -> x : L.map (T.drop (T.length s) . fst) xs-        u = T.concat [t,s,t]-tl_findSplit s t        = (TL.split s `eq` splitty) u-  where splitty v       = case TL.find s v of-                            (x,xs) -> x : L.map (TL.drop (TL.length s) . fst) xs-        u = TL.concat [t,s,t]-t_split_split s         = unsquare ((T.split s `eq` Slow.split s) .-                                    T.intercalate s)-tl_split_split s        = unsquare (((TL.split (chunkify s) . chunkify) `eq`-                                     (map chunkify . T.split s)) .-                                    T.intercalate s)+t_split_split s         = (T.split s `eq` Slow.split s) . T.intercalate s+tl_split_split s        = ((TL.split (TL.fromStrict s) . TL.fromStrict) `eq`+                           (map TL.fromStrict . T.split s)) . T.intercalate s t_split_i (NotEmpty t)  = id `eq` (T.intercalate t . T.split t) tl_split_i (NotEmpty t) = id `eq` (TL.intercalate t . TL.split t)  t_splitBy p       = splitBy p `eqP` (map unpackS . T.splitBy p)-t_splitBy_count c = (L.length . T.splitBy (==c)) `eq` ((1+) . T.count (T.singleton c))+t_splitBy_count c = (L.length . T.splitBy (==c)) `eq`+                    ((1+) . T.count (T.singleton c)) t_splitBy_split c = T.splitBy (==c) `eq` T.split (T.singleton c) tl_splitBy p      = splitBy p `eqP` (map unpackS . TL.splitBy p) @@ -444,9 +547,8 @@ t_chunksOf_length k t = len == T.length t || (k <= 0 && len == 0)   where len = L.sum . L.map T.length $ T.chunksOf k t -chunkify = TL.fromChunks . (:[])--tl_chunksOf k = T.chunksOf k `eq` (map (T.concat . TL.toChunks) . TL.chunksOf (fromIntegral k) . chunkify)+tl_chunksOf k = T.chunksOf k `eq` (map (T.concat . TL.toChunks) .+                                   TL.chunksOf (fromIntegral k) . TL.fromStrict)  t_lines           = L.lines       `eqP` (map unpackS . T.lines) tl_lines          = L.lines       `eqP` (map unpackS . TL.lines)@@ -463,13 +565,15 @@ t_words           = L.words       `eqP` (map unpackS . T.words)  tl_words          = L.words       `eqP` (map unpackS . TL.words)-t_unlines         = unsquare (L.unlines `eq` (unpackS . T.unlines . map packS))-tl_unlines        = unsquare (L.unlines `eq` (unpackS . TL.unlines . map packS))-t_unwords         = unsquare (L.unwords `eq` (unpackS . T.unwords . map packS))-tl_unwords        = unsquare (L.unwords `eq` (unpackS . TL.unwords . map packS))+t_unlines         = L.unlines `eq` (unpackS . T.unlines . map packS)+tl_unlines        = L.unlines `eq` (unpackS . TL.unlines . map packS)+t_unwords         = L.unwords `eq` (unpackS . T.unwords . map packS)+tl_unwords        = L.unwords `eq` (unpackS . TL.unwords . map packS) -s_isPrefixOf s    = L.isPrefixOf s `eqP` (S.isPrefixOf (S.stream $ packS s) . S.stream)-sf_isPrefixOf p s = (L.isPrefixOf s . L.filter p) `eqP` (S.isPrefixOf (S.stream $ packS s) . S.filter p . S.stream)+s_isPrefixOf s    = L.isPrefixOf s `eqP`+                    (S.isPrefixOf (S.stream $ packS s) . S.stream)+sf_isPrefixOf p s = (L.isPrefixOf s . L.filter p) `eqP`+                    (S.isPrefixOf (S.stream $ packS s) . S.filter p . S.stream) t_isPrefixOf s    = L.isPrefixOf s`eqP` T.isPrefixOf (packS s) tl_isPrefixOf s   = L.isPrefixOf s`eqP` TL.isPrefixOf (packS s) t_isSuffixOf s    = L.isSuffixOf s`eqP` T.isSuffixOf (packS s)@@ -477,8 +581,22 @@ t_isInfixOf s     = L.isInfixOf s `eqP` T.isInfixOf (packS s) tl_isInfixOf s    = L.isInfixOf s `eqP` TL.isInfixOf (packS s) +prefixed (p:ps) (t:ts)+    | p == t = prefixed ps ts+prefixed [] ts = Just ts+prefixed _  _  = Nothing++t_prefixed s      = (fmap packS . prefixed s) `eqP` T.prefixed (packS s)+tl_prefixed s     = (fmap packS . prefixed s) `eqP` TL.prefixed (packS s)++suffixed p t = reverse `fmap` prefixed (reverse p) (reverse t)++t_suffixed s      = (fmap packS . suffixed s) `eqP` T.suffixed (packS s)+tl_suffixed s     = (fmap packS . suffixed s) `eqP` TL.suffixed (packS s)+ sf_elem p c       = (L.elem c . L.filter p) `eqP` (S.elem c . S.filter p)-sf_filter q p     = (L.filter p . L.filter q) `eqP` (unpackS . S.filter p . S.filter q)+sf_filter q p     = (L.filter p . L.filter q) `eqP`+                    (unpackS . S.filter p . S.filter q) t_filter p        = L.filter p    `eqP` (unpackS . T.filter p) tl_filter p       = L.filter p    `eqP` (unpackS . TL.filter p) sf_findBy q p     = (L.find p . L.filter q) `eqP` (S.findBy p . S.filter q)@@ -487,29 +605,33 @@ t_partition p     = L.partition p `eqP` (unpack2 . T.partitionBy p) tl_partition p    = L.partition p `eqP` (unpack2 . TL.partitionBy p) -sf_index p s      = forAll (choose (-l,l*2)) ((L.filter p s L.!!) `eq` S.index (S.filter p $ packS s))+sf_index p s      = forAll (choose (-l,l*2))+                    ((L.filter p s L.!!) `eq` S.index (S.filter p $ packS s))     where l = L.length s t_index s         = forAll (choose (-l,l*2)) ((s L.!!) `eq` T.index (packS s))     where l = L.length s -tl_index s        = forAll (choose (-l,l*2)) ((s L.!!) `eq` (TL.index (packS s) . fromIntegral))+tl_index s        = forAll (choose (-l,l*2))+                    ((s L.!!) `eq` (TL.index (packS s) . fromIntegral))     where l = L.length s  t_findIndex p     = L.findIndex p `eqP` T.findIndex p-t_count t         = (subtract 1 . L.length . T.split t) `eq` T.count t-tl_count t        = (subtract 1 . L.genericLength . TL.split t) `eq` TL.count t+t_count (NotEmpty t)  = (subtract 1 . L.length . T.split t) `eq` T.count t+tl_count (NotEmpty t) = (subtract 1 . L.genericLength . TL.split t) `eq`+                        TL.count t t_zip s           = L.zip s `eqP` T.zip (packS s) tl_zip s          = L.zip s `eqP` TL.zip (packS s)-sf_zipWith p c s  = (L.zipWith c (L.filter p s) . L.filter p) `eqP` (unpackS . S.zipWith c (S.filter p $ packS s) . S.filter p)+sf_zipWith p c s  = (L.zipWith c (L.filter p s) . L.filter p) `eqP`+                    (unpackS . S.zipWith c (S.filter p $ packS s) . S.filter p) t_zipWith c s     = L.zipWith c s `eqP` (unpackS . T.zipWith c (packS s)) tl_zipWith c s    = L.zipWith c s `eqP` (unpackS . TL.zipWith c (packS s)) -t_indices = unsquare (\s -> Slow.indices s `eq` indices s)-tl_indices = unsquare (\s -> lazyIndices s `eq` S.indices s)-    where lazyIndices s t = map fromIntegral $ Slow.indices (conc s) (conc t)+t_indices  (NotEmpty s) = Slow.indices s `eq` indices s+tl_indices (NotEmpty s) = lazyIndices s `eq` S.indices s+    where lazyIndices ss t = map fromIntegral $ Slow.indices (conc ss) (conc t)           conc = T.concat . TL.toChunks-t_indices_occurs t = unsquare (\ts -> let s = T.intercalate t ts-                                      in Slow.indices t s == indices t s)+t_indices_occurs (NotEmpty t) ts = let s = T.intercalate t ts+                                   in Slow.indices t s == indices t s  -- Bit shifts. shiftL w = forAll (choose (0,width-1)) $ \k -> Bits.shiftL w k == U.shiftL w k@@ -526,15 +648,103 @@ shiftR_Word16 = shiftR :: Word16 -> Property shiftR_Word32 = shiftR :: Word32 -> Property --- Builder-t_builderSingleton = id `eqP` (unpackS . TB.toLazyText . mconcat . map TB.singleton)-t_builderFromText = L.concat `eq` (unpackS . TB.toLazyText . mconcat . map (TB.fromText . packS))-t_builderAssociative s1 s2 s3 = TB.toLazyText (b1 `mappend` (b2 `mappend` b3)) ==-                                TB.toLazyText ((b1 `mappend` b2) `mappend` b3)-    where b1 = TB.fromText (packS s1)-          b2 = TB.fromText (packS s2)-          b3 = TB.fromText (packS s3)+-- Builder. +t_builderSingleton = id `eqP`+                     (unpackS . TB.toLazyText . mconcat . map TB.singleton)+t_builderFromText = L.concat `eq` (unpackS . TB.toLazyText . mconcat .+                                   map (TB.fromText . packS))+t_builderAssociative s1 s2 s3 =+    TB.toLazyText (b1 `mappend` (b2 `mappend` b3)) ==+    TB.toLazyText ((b1 `mappend` b2) `mappend` b3)+  where b1 = TB.fromText (packS s1)+        b2 = TB.fromText (packS s2)+        b3 = TB.fromText (packS s3)++-- Input and output.++-- Work around lack of Show instance for TextEncoding.+data Encoding = E String TextEncoding++instance Show Encoding where show (E n _) = "utf" ++ n++instance Arbitrary Encoding where+    arbitrary = oneof . map return $+      [ E "8" utf8, E "8_bom" utf8_bom, E "16" utf16, E "16le" utf16le,+        E "16be" utf16be, E "32" utf32, E "32le" utf32le, E "32be" utf32be ]++windowsNewlineMode  = NewlineMode { inputNL = CRLF, outputNL = CRLF }++instance Show Newline where+    show CRLF = "CRLF"+    show LF   = "LF"++instance Show NewlineMode where+    show (NewlineMode i o) = "NewlineMode { inputNL = " ++ show i +++                             ", outputNL = " ++ show o ++ " }"++instance Arbitrary NewlineMode where+    arbitrary = oneof . map return $+      [ noNewlineTranslation, universalNewlineMode, nativeNewlineMode,+        windowsNewlineMode ]++instance Arbitrary BufferMode where+    arbitrary = oneof [ return NoBuffering,+                        return LineBuffering,+                        return (BlockBuffering Nothing),+                        (BlockBuffering . Just . (+1) . fromIntegral) `fmap`+                        (arbitrary :: Gen Word16) ]++-- This test harness is complex!  What property are we checking?+--+-- Reading after writing a multi-line file should give the same+-- results as were written.+--+-- What do we vary while checking this property?+-- * The lines themselves, scrubbed to contain neither CR nor LF.  (By+--   working with a list of lines, we ensure that the data will+--   sometimes contain line endings.)+-- * Encoding.+-- * Newline translation mode.+-- * Buffering.+write_read unline filt writer reader (E _ enc) nl buf ts =+    monadicIO $ assert . (==t) =<< run act+  where t = unline . map (filt (not . (`elem` "\r\n"))) $ ts+        act = withTempFile $ \path h -> do+                hSetEncoding h enc+                hSetNewlineMode h nl+                hSetBuffering h buf+                () <- writer h t+                hClose h+                bracket (openFile path ReadMode) hClose $ \h' -> do+                  hSetEncoding h' enc+                  hSetNewlineMode h' nl+                  hSetBuffering h' buf+                  r <- reader h'+                  r `deepseq` return r++t_put_get = write_read T.unlines T.filter put get+  where put h = withRedirect h stdout . T.putStr+        get h = withRedirect h stdin T.getContents+tl_put_get = write_read TL.unlines TL.filter put get+  where put h = withRedirect h stdout . TL.putStr+        get h = withRedirect h stdin TL.getContents+t_write_read = write_read T.unlines T.filter T.hPutStr T.hGetContents+tl_write_read = write_read TL.unlines TL.filter TL.hPutStr TL.hGetContents++t_write_read_line e m b t = write_read head T.filter T.hPutStrLn+                            T.hGetLine e m b [t]+tl_write_read_line e m b t = write_read head TL.filter TL.hPutStrLn+                             TL.hGetLine e m b [t]++-- Low-level.++t_dropWord16 m t = dropWord16 m t `T.isSuffixOf` t+t_takeWord16 m t = takeWord16 m t `T.isPrefixOf` t+t_take_drop_16 m t = T.append (takeWord16 n t) (dropWord16 n t) == t+  where n = small m+t_use_from t = monadicIO $ assert . (==t) =<< run (useAsPtr t fromPtr)+ -- Regression tests. s_filter_eq s = S.filter p t == S.streamList (filter p s)     where p = (/= S.last t)@@ -560,17 +770,26 @@     testProperty "t_singleton" t_singleton,     testProperty "tl_singleton" tl_singleton,     testProperty "tl_unstreamChunks" tl_unstreamChunks,-    testProperty "tl_chunk_unchunk" tl_chunk_unchunk+    testProperty "tl_chunk_unchunk" tl_chunk_unchunk,+    testProperty "tl_from_to_strict" tl_from_to_strict   ],    testGroup "transcoding" [     testProperty "t_ascii" t_ascii,+    testProperty "tl_ascii" tl_ascii,     testProperty "t_utf8" t_utf8,     testProperty "tl_utf8" tl_utf8,     testProperty "t_utf16LE" t_utf16LE,+    testProperty "tl_utf16LE" tl_utf16LE,     testProperty "t_utf16BE" t_utf16BE,+    testProperty "tl_utf16BE" tl_utf16BE,     testProperty "t_utf32LE" t_utf32LE,-    testProperty "t_utf32BE" t_utf32BE+    testProperty "tl_utf32LE" tl_utf32LE,+    testProperty "t_utf32BE" t_utf32BE,+    testProperty "tl_utf32BE" tl_utf32BE,+    testGroup "errors" [+      testProperty "t_utf8_err" t_utf8_err+    ]   ],    testGroup "instances" [@@ -635,8 +854,11 @@     testProperty "tl_null" tl_null,     testProperty "s_length" s_length,     testProperty "sf_length" sf_length,+    testProperty "sl_length" sl_length,     testProperty "t_length" t_length,-    testProperty "tl_length" tl_length+    testProperty "tl_length" tl_length,+    testProperty "t_compareLength" t_compareLength,+    testProperty "tl_compareLength" tl_compareLength   ],    testGroup "transformations" [@@ -680,7 +902,9 @@       testProperty "t_justifyLeft" t_justifyLeft,       testProperty "tl_justifyLeft" tl_justifyLeft,       testProperty "t_justifyRight" t_justifyRight,-      testProperty "tl_justifyRight" tl_justifyRight+      testProperty "tl_justifyRight" tl_justifyRight,+      testProperty "t_center" t_center,+      testProperty "tl_center" tl_center     ]   ], @@ -799,6 +1023,8 @@       testProperty "tl_break_id" tl_break_id,       testProperty "t_break_start" t_break_start,       testProperty "tl_break_start" tl_break_start,+      testProperty "t_breakEnd_end" t_breakEnd_end,+      testProperty "tl_breakEnd_end" tl_breakEnd_end,       testProperty "t_breakBy" t_breakBy,       testProperty "tl_breakBy" tl_breakBy,       testProperty "t_group" t_group,@@ -812,8 +1038,13 @@     ],      testGroup "breaking many" [-      testProperty "t_findSplit" t_findSplit,-      testProperty "tl_findSplit" tl_findSplit,+      testProperty "t_findAppendId" t_findAppendId,+      testProperty "tl_findAppendId" tl_findAppendId,+      testProperty "t_findContains" t_findContains,+      testProperty "tl_findContains" tl_findContains,+      testProperty "sl_filterCount" sl_filterCount,+      testProperty "t_findCount" t_findCount,+      testProperty "tl_findCount" tl_findCount,       testProperty "t_split_split" t_split_split,       testProperty "tl_split_split" tl_split_split,       testProperty "t_split_i" t_split_i,@@ -848,7 +1079,14 @@     testProperty "t_isSuffixOf" t_isSuffixOf,     testProperty "tl_isSuffixOf" tl_isSuffixOf,     testProperty "t_isInfixOf" t_isInfixOf,-    testProperty "tl_isInfixOf" tl_isInfixOf+    testProperty "tl_isInfixOf" tl_isInfixOf,++    testGroup "view" [+      testProperty "t_prefixed" t_prefixed,+      testProperty "tl_prefixed" tl_prefixed,+      testProperty "t_suffixed" t_suffixed,+      testProperty "tl_suffixed" tl_suffixed+    ]   ],    testGroup "searching" [@@ -900,5 +1138,23 @@     testProperty "t_builderSingleton" t_builderSingleton,     testProperty "t_builderFromText" t_builderFromText,     testProperty "t_builderAssociative" t_builderAssociative+  ],++  testGroup "input-output" [+    testProperty "t_write_read" t_write_read,+    testProperty "tl_write_read" tl_write_read,+    testProperty "t_write_read_line" t_write_read_line,+    testProperty "tl_write_read_line" tl_write_read_line+    -- These tests are subject to I/O race conditions when run under+    -- test-framework-quickcheck2.+    -- testProperty "t_put_get" t_put_get+    -- testProperty "tl_put_get" tl_put_get+  ],++  testGroup "lowlevel" [+    testProperty "t_dropWord16" t_dropWord16,+    testProperty "t_takeWord16" t_takeWord16,+    testProperty "t_take_drop_16" t_take_drop_16,+    testProperty "t_use_from" t_use_from   ]  ]

@@ -3,12 +3,15 @@ module QuickCheckUtils where  import Control.Arrow (first)+import Data.Char (chr)+import Data.Bits ((.&.)) import Data.Int (Int64) import Data.Word (Word8, Word16, Word32)+import Data.String (IsString, fromString) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import System.Random (Random(..), RandomGen)-import Test.QuickCheck (Arbitrary(..), choose, oneof, sized, variant, vector)+import Test.QuickCheck hiding ((.&.)) import qualified Data.ByteString as B  instance Random Int64 where@@ -17,7 +20,6 @@  instance Arbitrary Int64 where     arbitrary     = choose (minBound,maxBound)-    coarbitrary c = variant (fromEnum c `rem` 4)  instance Random Word8 where     randomR = integralRandomR@@ -25,11 +27,9 @@  instance Arbitrary Word8 where     arbitrary     = choose (minBound,maxBound)-    coarbitrary c = variant (fromEnum c `rem` 4)  instance Arbitrary B.ByteString where     arbitrary     = B.pack `fmap` arbitrary-    coarbitrary s = coarbitrary (B.unpack s)  instance Random Word16 where     randomR = integralRandomR@@ -37,7 +37,6 @@  instance Arbitrary Word16 where     arbitrary     = choose (minBound,maxBound)-    coarbitrary c = variant (fromEnum c `rem` 4)  instance Random Word32 where     randomR = integralRandomR@@ -45,41 +44,92 @@  instance Arbitrary Word32 where     arbitrary     = choose (minBound,maxBound)-    coarbitrary c = variant (fromEnum c `rem` 4) -instance Arbitrary Char where-    arbitrary     = oneof [choose ('\0','\55295'), choose ('\57344','\1114111')]-    coarbitrary c = variant (fromEnum c `rem` 4)+genUnicode :: IsString a => Gen a+genUnicode = fmap fromString string where+    string = sized $ \n ->+        do k <- choose (0,n)+           sequence [ char | _ <- [1..k] ]+    +    excluding :: [a -> Bool] -> Gen a -> Gen a+    excluding bad gen = loop+      where+        loop = do+          x <- gen+          if or (map ($ x) bad)+            then loop+            else return x+    +    reserved = [lowSurrogate, highSurrogate, noncharacter]+    lowSurrogate c = c >= 0xDC00 && c <= 0xDFFF+    highSurrogate c = c >= 0xD800 && c <= 0xDBFF+    noncharacter c = masked == 0xFFFE || masked == 0xFFFF+      where+        masked = c .&. 0xFFFF +    +    ascii = choose (0,0x7F)+    plane0 = choose (0xF0, 0xFFFF)+    plane1 = oneof [ choose (0x10000, 0x10FFF)+                   , choose (0x11000, 0x11FFF)+                   , choose (0x12000, 0x12FFF)+                   , choose (0x13000, 0x13FFF)+                   , choose (0x1D000, 0x1DFFF)+                   , choose (0x1F000, 0x1FFFF)+                   ]+    plane2 = oneof [ choose (0x20000, 0x20FFF)+                   , choose (0x21000, 0x21FFF)+                   , choose (0x22000, 0x22FFF)+                   , choose (0x23000, 0x23FFF)+                   , choose (0x24000, 0x24FFF)+                   , choose (0x25000, 0x25FFF)+                   , choose (0x26000, 0x26FFF)+                   , choose (0x27000, 0x27FFF)+                   , choose (0x28000, 0x28FFF)+                   , choose (0x29000, 0x29FFF)+                   , choose (0x2A000, 0x2AFFF)+                   , choose (0x2B000, 0x2BFFF)+                   , choose (0x2F000, 0x2FFFF)+                   ]+    plane14 = choose (0xE0000, 0xE0FFF)+    planes = [ascii, plane0, plane1, plane2, plane14]+    +    char = chr `fmap` excluding reserved (oneof planes) +-- For tests that have O(n^2) running times or input sizes, resize+-- their inputs to the square root of the originals.+unsquare :: (Arbitrary a, Show a, Testable b) => (a -> b) -> Property+unsquare = forAll smallArbitrary++smallArbitrary :: (Arbitrary a, Show a) => Gen a+smallArbitrary = sized $ \n -> resize (smallish n) arbitrary+  where smallish = round . (sqrt :: Double -> Double) . fromIntegral . abs+ instance Arbitrary T.Text where-    arbitrary     = T.pack `fmap` arbitrary-    coarbitrary s = coarbitrary (T.unpack s)+    arbitrary = T.pack `fmap` arbitrary  instance Arbitrary TL.Text where-    arbitrary     = TL.pack `fmap` arbitrary-    coarbitrary s = coarbitrary (TL.unpack s)+    arbitrary = (TL.fromChunks . map notEmpty) `fmap` smallArbitrary  newtype NotEmpty a = NotEmpty { notEmpty :: a }-    deriving (Eq, Ord, Show)+    deriving (Eq, Ord) +instance Show a => Show (NotEmpty a) where+    show (NotEmpty a) = show a+ instance Functor NotEmpty where     fmap f (NotEmpty a) = NotEmpty (f a)  instance Arbitrary a => Arbitrary (NotEmpty [a]) where     arbitrary   = sized (\n -> NotEmpty `fmap` (choose (1,n+1) >>= vector))-    coarbitrary = coarbitrary . notEmpty  instance Arbitrary (NotEmpty T.Text) where     arbitrary   = (fmap T.pack) `fmap` arbitrary-    coarbitrary = coarbitrary . notEmpty  instance Arbitrary (NotEmpty TL.Text) where     arbitrary   = (fmap TL.pack) `fmap` arbitrary-    coarbitrary = coarbitrary . notEmpty  instance Arbitrary (NotEmpty B.ByteString) where     arbitrary   = (fmap B.pack) `fmap` arbitrary-    coarbitrary = coarbitrary . notEmpty  data Small = S0  | S1  | S2  | S3  | S4  | S5  | S6  | S7            | S8  | S9  | S10 | S11 | S12 | S13 | S14 | S15@@ -120,7 +170,6 @@  instance Arbitrary Small where     arbitrary     = choose (minBound,maxBound)-    coarbitrary c = variant (fromEnum c `rem` 4)  integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) integralRandomR  (a,b) g = case randomR (fromIntegral a :: Integer,

@@ -1,12 +1,12 @@ name:           text-version:        0.7.2.1+version:        0.8.0.0 synopsis:       An efficient packed Unicode text type description:    An efficient packed Unicode text type. license:        BSD3 license-file:   LICENSE-author:         Tom Harper <rtharper@aftereternity.co.uk>+author:         Tom Harper <rtomharper@googlemail.com> maintainer:     Bryan O'Sullivan <bos@serpentine.com>-                Tom Harper <rtharper@aftereternity.co.uk>+                Tom Harper <rrtomharper@googlemail.com>                 Duncan Coutts <duncan@haskell.org> copyright:      2008-2009 Tom Harper, 2009-2010 Bryan O'Sullivan category:       Data, Text@@ -40,6 +40,7 @@     Data.Text.Foreign     Data.Text.IO     Data.Text.Lazy+    Data.Text.Lazy.Builder     Data.Text.Lazy.Encoding     Data.Text.Lazy.IO   other-modules:@@ -56,7 +57,6 @@     Data.Text.Fusion.Size     Data.Text.IO.Internal     Data.Text.Internal-    Data.Text.Lazy.Builder     Data.Text.Lazy.Encoding.Fusion     Data.Text.Lazy.Fusion     Data.Text.Lazy.Internal@@ -85,3 +85,4 @@     ghc-options: -fwarn-tabs   if flag(developer)     ghc-options: -Werror+    cpp-options: -DASSERTS