diff --git a/Data/Text.hs b/Data/Text.hs --- a/Data/Text.hs +++ b/Data/Text.hs @@ -8,7 +8,7 @@ -- (c) Duncan Coutts 2009 -- -- License : BSD-style --- Maintainer : rtharper@aftereternity.co.uk, bos@serpentine.com, +-- Maintainer : bos@serpentine.com, rtharper@aftereternity.co.uk, -- duncan@haskell.org -- Stability : experimental -- Portability : GHC @@ -137,16 +137,17 @@ , count -- * Zipping and unzipping + , zip , zipWith -- -* Ordered text - , -- sort + -- , sort ) where import Prelude (Char, Bool(..), Functor(..), Int, Maybe(..), String, - Eq(..), (++), + Eq(..), Ord(..), (++), Read(..), Show(..), - (&&), (||), (+), (-), (<), (>), (<=), (>=), (.), ($), + (&&), (||), (+), (-), (.), ($), not, return, otherwise) import Control.Exception (assert) import Data.Char (isSpace) @@ -158,8 +159,10 @@ import Data.String (IsString(..)) import qualified Data.Text.Fusion as S -import Data.Text.Fusion (Stream(..), Step(..), stream, reverseStream, unstream) -import Data.Text.Internal (Text(..), empty, text) +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_, unsafeHead, unsafeTail) import Data.Text.UnsafeChar (unsafeChr) @@ -172,8 +175,13 @@ -- one 'Text' value. instance Eq Text where - t1 == t2 = (stream t1) `S.eq` (stream t2) + t1 == t2 = stream t1 == stream t2 + {-# INLINE (==) #-} +instance Ord Text where + compare t1 t2 = compare (stream t1) (stream t2) + {-# INLINE compare #-} + instance Show Text where showsPrec p ps r = showsPrec p (unpack ps) r @@ -195,36 +203,19 @@ -- -- This function is subject to array fusion. pack :: String -> Text -pack str = (unstream (stream_list str)) - where - stream_list s0 = S.Stream next s0 (P.length s0) -- total guess - where - next [] = S.Done - next (x:xs) = S.Yield x xs +pack = unstream . S.streamList {-# INLINE [1] pack #-} --- TODO: Has to do validation! -- No, it doesn't, the -- | /O(n)/ Convert a Text into a String. -- Subject to array fusion. unpack :: Text -> String -unpack txt = (unstream_list (stream txt)) - where - unstream_list (S.Stream next s0 _len) = unfold s0 - where - unfold !s = case next s of - S.Done -> [] - S.Skip s' -> unfold s' - S.Yield x s' -> x : unfold s' +unpack = S.unstreamList . stream {-# INLINE [1] unpack #-} -- | /O(1)/ Convert a character into a Text. -- Subject to array fusion. singleton :: Char -> Text -singleton c = unstream (Stream next (c:[]) 1) - where - {-# INLINE next #-} - next (k:ks) = Yield k ks - next [] = Done +singleton = unstream . S.singleton {-# INLINE [1] singleton #-} -- ----------------------------------------------------------------------------- @@ -255,10 +246,10 @@ copy arr2 off2 (len2+off2) arr len1 return arr where - copy arr i max arr' j - | i >= max = return () + copy arr i top arr' j + | i >= top = return () | otherwise = do A.unsafeWrite arr' j (arr `A.unsafeIndex` i) - copy arr (i+1) max arr' (j+1) + copy arr (i+1) top arr' (j+1) {-# INLINE append #-} {-# RULES @@ -312,13 +303,6 @@ S.last (stream t) = last t #-} --- | 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 arr off len | len == 0 = empty - | otherwise = text arr off len -{-# INLINE textP #-} - -- | /O(1)/ Returns all characters after the head of a 'Text', which -- must be non-empty. Subject to array fusion. tail :: Text -> Text @@ -517,7 +501,7 @@ -- | /O(n)/ 'scanr' is the right-to-left dual of 'scanl'. -- --- > scanr f v t == reverse (scanl (flip f) v t) +-- > scanr f v == reverse . scanl (flip f) v . reverse scanr :: (Char -> Char -> Char) -> Char -> Text -> Text scanr f z = S.reverse . S.reverseScanr f z . reverseStream {-# INLINE scanr #-} @@ -554,7 +538,7 @@ -- ** Generating and unfolding 'Text's -- | /O(n)/ 'replicate' @n@ @c@ is a 'Text' of length @n@ with @c@ the --- value of every element. +-- value of every element. Subject to fusion. replicate :: Int -> Char -> Text replicate n c = unstream (S.replicate n c) {-# INLINE replicate #-} @@ -564,7 +548,8 @@ -- 'Text' from a seed value. The function takes the element and -- returns 'Nothing' if it is done producing the 'Text', otherwise -- 'Just' @(a,b)@. In this case, @a@ is the next 'Char' in the --- string, and @b@ is the seed value for further production. +-- string, and @b@ is the seed value for further production. Subject +-- to fusion. unfoldr :: (a -> Maybe (Char,a)) -> a -> Text unfoldr f s = unstream (S.unfoldr f s) {-# INLINE unfoldr #-} @@ -573,7 +558,8 @@ -- value. However, the length of the result should be limited by the -- first argument to 'unfoldrN'. This function is more efficient than -- 'unfoldr' when the maximum length of the result is known and --- correct, otherwise its performance is similar to 'unfoldr'. +-- correct, otherwise its performance is similar to 'unfoldr'. Subject +-- to fusion. unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Text unfoldrN n f s = unstream (S.unfoldrN n f s) {-# INLINE unfoldrN #-} @@ -583,7 +569,7 @@ -- | /O(n)/ 'take' @n@, applied to a 'Text', returns the prefix of the -- 'Text' of length @n@, or the 'Text' itself if @n@ is greater than --- the length of the Text. +-- the length of the Text. Subject to fusion. take :: Int -> Text -> Text take n t@(Text arr off len) | n <= 0 = empty @@ -605,15 +591,14 @@ -- | /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'. +-- length of the 'Text'. Subject to fusion. drop :: Int -> Text -> Text drop n t@(Text arr off len) | n <= 0 = t | n >= len = empty | otherwise = loop 0 0 - where end = off + len - loop !i !cnt - | i >= end || cnt >= n = Text arr (off+i) (len-i) + where loop !i !cnt + | i >= len || cnt >= n = Text arr (off+i) (len-i) | otherwise = loop (i+d) (cnt+1) where d = iter_ t i {-# INLINE [1] drop #-} @@ -756,11 +741,10 @@ -- > splitWith (=='a') "aabbaca" == ["","","bb","c",""] -- > splitWith (=='a') [] == [] splitWith :: (Char -> Bool) -> Text -> [Text] -splitWith p = loop - where loop s | null s = [] - | otherwise = if null s' - then [s] - else l : loop (unsafeTail s') +splitWith _ (Text _off _arr 0) = [] +splitWith p t = loop t + where loop s | null s' = [l] + | otherwise = l : loop (unsafeTail s') where (l, s') = break p s {-# INLINE splitWith #-} @@ -837,7 +821,7 @@ ------------------------------------------------------------------------------- -- ** Indexing 'Text's --- | /O(1)/ 'Text' index (subscript) operator, starting from 0. +-- | /O(n)/ 'Text' index (subscript) operator, starting from 0. index :: Text -> Int -> Char index t n = S.index (stream t) n {-# INLINE index #-} @@ -881,10 +865,19 @@ ------------------------------------------------------------------------------- -- * Zipping +-- | /O(n)/ 'zip' takes two 'Text's and returns a list of +-- corresponding pairs of bytes. If one input 'Text' is short, +-- excess elements of the longer 'Text' are discarded. This is +-- equivalent to a pair of 'unpack' operations. +zip :: Text -> Text -> [(Char,Char)] +zip a b = S.unstreamList $ S.zipWith (,) (stream a) (stream b) +{-# INLINE [0] zip #-} + -- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function -- given as the first argument, instead of a tupling function. zipWith :: (Char -> Char -> Char) -> Text -> Text -> Text zipWith f t1 t2 = unstream (S.zipWith f (stream t1) (stream t2)) +{-# INLINE [0] zipWith #-} -- | /O(n)/ Breaks a 'Text' up into a list of words, delimited by 'Char's -- representing white space. @@ -977,6 +970,7 @@ isInfixOf :: Text -> Text -> Bool isInfixOf needle haystack = L.any (isPrefixOf needle) (tails haystack) {-# INLINE isInfixOf #-} +-- TODO: a better implementation emptyError :: String -> a emptyError fun = P.error ("Data.Text." ++ fun ++ ": empty input") diff --git a/Data/Text/Array.hs b/Data/Text/Array.hs --- a/Data/Text/Array.hs +++ b/Data/Text/Array.hs @@ -1,11 +1,13 @@ {-# LANGUAGE BangPatterns, CPP, ExistentialQuantification, MagicHash, Rank2Types, ScopedTypeVariables, UnboxedTuples #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} -- | -- Module : Data.Text.Array -- Copyright : (c) Bryan O'Sullivan 2009 -- -- License : BSD-style --- Maintainer : bos@serpentine.com, +-- Maintainer : bos@serpentine.com, rtharper@aftereternity.co.uk, +-- duncan@haskell.org -- Stability : experimental -- Portability : portable -- diff --git a/Data/Text/Encoding.hs b/Data/Text/Encoding.hs --- a/Data/Text/Encoding.hs +++ b/Data/Text/Encoding.hs @@ -5,7 +5,7 @@ -- (c) Duncan Coutts 2009 -- -- License : BSD-style --- Maintainer : rtharper@aftereternity.co.uk, bos@serpentine.com, +-- Maintainer : bos@serpentine.com, rtharper@aftereternity.co.uk, -- duncan@haskell.org -- Stability : experimental -- Portability : portable diff --git a/Data/Text/Encoding/Fusion.hs b/Data/Text/Encoding/Fusion.hs --- a/Data/Text/Encoding/Fusion.hs +++ b/Data/Text/Encoding/Fusion.hs @@ -1,7 +1,7 @@ {-# LANGUAGE BangPatterns #-} -- | --- Module : Data.Text.Encoding +-- Module : Data.Text.Encoding.Fusion -- Copyright : (c) Tom Harper 2008-2009, -- (c) Bryan O'Sullivan 2009, -- (c) Duncan Coutts 2009 @@ -28,22 +28,15 @@ -- * Unstreaming , unstream - -- * Restreaming - -- Restreaming is the act of converting from one 'Stream' - -- representation to another. - , restreamUtf8 - , restreamUtf16LE - , restreamUtf16BE - , restreamUtf32LE - , restreamUtf32BE + , module Data.Text.Encoding.Fusion.Common ) where import Control.Exception (assert) -import Data.Bits (shiftL, shiftR, (.&.)) +import Data.Bits (shiftL) import Data.ByteString as B import Data.ByteString.Internal (ByteString(..), mallocByteString, memcpy) -import Data.Char (ord) import Data.Text.Fusion (Step(..), Stream(..)) +import Data.Text.Encoding.Fusion.Common import Data.Text.UnsafeChar (unsafeChr, unsafeChr8, unsafeChr32) import Data.Word (Word8, Word16, Word32) import Foreign.ForeignPtr (withForeignPtr, ForeignPtr) @@ -55,15 +48,6 @@ import qualified Data.Text.Encoding.Utf16 as U16 import qualified Data.Text.Encoding.Utf32 as U32 --- Specialised, strict Maybe-like type. -data M = N - | J {-# UNPACK #-} !Word8 - deriving (Eq, Ord, Show) - --- Restreaming state. -data S s = S {-# UNPACK #-} !s - {-# UNPACK #-} !M {-# UNPACK #-} !M {-# UNPACK #-} !M - streamASCII :: ByteString -> Stream Char streamASCII bs = Stream next 0 l where @@ -174,149 +158,25 @@ idx = fromIntegral . B.unsafeIndex bs :: Int -> Word32 {-# INLINE [0] streamUtf32LE #-} --- | /O(n)/ Convert a Stream Char into a UTF-8 encoded Stream Word8. -restreamUtf8 :: Stream Char -> Stream Word8 -restreamUtf8 (Stream next0 s0 len) = - Stream next (S s0 N N N) (len*2) - where - {-# INLINE next #-} - next (S s N N N) = case next0 s of - Done -> Done - Skip s' -> Skip (S s' N N N) - Yield x xs - | n <= 0x7F -> Yield c (S xs N N N) - | n <= 0x07FF -> Yield a2 (S xs (J b2) N N) - | n <= 0xFFFF -> Yield a3 (S xs (J b3) (J c3) N) - | otherwise -> Yield a4 (S xs (J b4) (J c4) (J d4)) - where - n = ord x - c = fromIntegral n - (a2,b2) = U8.ord2 x - (a3,b3,c3) = U8.ord3 x - (a4,b4,c4,d4) = U8.ord4 x - next (S s (J x2) N N) = Yield x2 (S s N N N) - next (S s (J x2) x3 N) = Yield x2 (S s x3 N N) - next (S s (J x2) x3 x4) = Yield x2 (S s x3 x4 N) - next _ = internalError "restreamUtf8" -{-# INLINE restreamUtf8 #-} - -restreamUtf16BE :: Stream Char -> Stream Word8 -restreamUtf16BE (Stream next0 s0 len) = - Stream next (S s0 N N N) (len*2) - where - {-# INLINE next #-} - next (S s N N N) = case next0 s of - Done -> Done - Skip s' -> Skip (S s' N N N) - Yield x xs - | n < 0x10000 -> Yield (fromIntegral $ n `shiftR` 8) $ - S xs (J $ fromIntegral n) N N - | otherwise -> Yield c1 $ - S xs (J c2) (J c3) (J c4) - where - n = ord x - n1 = n - 0x10000 - c1 = fromIntegral (n1 `shiftR` 18 + 0xD8) - c2 = fromIntegral (n1 `shiftR` 10) - n2 = n1 .&. 0x3FF - c3 = fromIntegral (n2 `shiftR` 8 + 0xDC) - c4 = fromIntegral n2 - next (S s (J x2) N N) = Yield x2 (S s N N N) - next (S s (J x2) x3 N) = Yield x2 (S s x3 N N) - next (S s (J x2) x3 x4) = Yield x2 (S s x3 x4 N) - next _ = internalError "restreamUtf16BE" -{-# INLINE restreamUtf16BE #-} - -restreamUtf16LE :: Stream Char -> Stream Word8 -restreamUtf16LE (Stream next0 s0 len) = - Stream next (S s0 N N N) (len*2) - where - {-# INLINE next #-} - next (S s N N N) = case next0 s of - Done -> Done - Skip s' -> Skip (S s' N N N) - Yield x xs - | n < 0x10000 -> Yield (fromIntegral n) $ - S xs (J (fromIntegral $ shiftR n 8)) N N - | otherwise -> Yield c1 $ - S xs (J c2) (J c3) (J c4) - where - n = ord x - n1 = n - 0x10000 - c2 = fromIntegral (shiftR n1 18 + 0xD8) - c1 = fromIntegral (shiftR n1 10) - n2 = n1 .&. 0x3FF - c4 = fromIntegral (shiftR n2 8 + 0xDC) - c3 = fromIntegral n2 - next (S s (J x2) N N) = Yield x2 (S s N N N) - next (S s (J x2) x3 N) = Yield x2 (S s x3 N N) - next (S s (J x2) x3 x4) = Yield x2 (S s x3 x4 N) - next _ = internalError "restreamUtf16LE" -{-# INLINE restreamUtf16LE #-} - -restreamUtf32BE :: Stream Char -> Stream Word8 -restreamUtf32BE (Stream next0 s0 len) = - Stream next (S s0 N N N) (len*2) - where - {-# INLINE next #-} - next (S s N N N) = case next0 s of - Done -> Done - Skip s' -> Skip (S s' N N N) - Yield x xs -> Yield c1 (S xs (J c2) (J c3) (J c4)) - where - n = ord x - c1 = fromIntegral $ shiftR n 24 - c2 = fromIntegral $ shiftR n 16 - c3 = fromIntegral $ shiftR n 8 - c4 = fromIntegral n - next (S s (J x2) N N) = Yield x2 (S s N N N) - next (S s (J x2) x3 N) = Yield x2 (S s x3 N N) - next (S s (J x2) x3 x4) = Yield x2 (S s x3 x4 N) - next _ = internalError "restreamUtf32BE" -{-# INLINE restreamUtf32BE #-} - -restreamUtf32LE :: Stream Char -> Stream Word8 -restreamUtf32LE (Stream next0 s0 len) = - Stream next (S s0 N N N) (len*2) - where - {-# INLINE next #-} - next (S s N N N) = case next0 s of - Done -> Done - Skip s' -> Skip (S s' N N N) - Yield x xs -> Yield c1 (S xs (J c2) (J c3) (J c4)) - where - n = ord x - c4 = fromIntegral $ shiftR n 24 - c3 = fromIntegral $ shiftR n 16 - c2 = fromIntegral $ shiftR n 8 - c1 = fromIntegral n - next (S s (J x2) N N) = Yield x2 (S s N N N) - next (S s (J x2) x3 N) = Yield x2 (S s x3 N N) - next (S s (J x2) x3 x4) = Yield x2 (S s x3 x4 N) - next _ = internalError "restreamUtf32LE" -{-# INLINE restreamUtf32LE #-} - - -- | /O(n)/ Convert a 'Stream' 'Word8' to a 'ByteString'. unstream :: Stream Word8 -> ByteString unstream (Stream next s0 len) = unsafePerformIO $ do - fp0 <- mallocByteString len - loop fp0 len 0 s0 + mallocByteString len >>= loop len 0 s0 where - loop !fp !n !off !s = case next s of + loop !n !off !s fp = case next s of Done -> trimUp fp n off - Skip s' -> loop fp n off s' + Skip s' -> loop n off s' fp Yield x s' - | n == off -> realloc fp n off s' x + | off == n -> realloc fp n off s' x | otherwise -> do withForeignPtr fp $ \p -> pokeByteOff p off x - loop fp n (off+1) s' + loop n (off+1) s' fp {-# NOINLINE realloc #-} realloc fp n off s x = do let n' = n+n fp' <- copy0 fp n n' withForeignPtr fp' $ \p -> pokeByteOff p off x - loop fp' n' (off+1) s + loop n' (off+1) s fp' {-# NOINLINE trimUp #-} trimUp fp _ off = return $! PS fp 0 off copy0 :: ForeignPtr Word8 -> Int -> Int -> IO (ForeignPtr Word8) @@ -324,12 +184,8 @@ dest <- mallocByteString destLen withForeignPtr src $ \src' -> withForeignPtr dest $ \dest' -> - memcpy dest' src' (fromIntegral destLen) + memcpy dest' src' (fromIntegral srcLen) return dest - -internalError :: String -> a -internalError func = - error $ "Data.Text.Encoding.Fusion." ++ func ++ ": internal error" encodingError :: String -> a encodingError encoding = diff --git a/Data/Text/Encoding/Fusion/Common.hs b/Data/Text/Encoding/Fusion/Common.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Encoding/Fusion/Common.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Data.Text.Encoding.Fusion.Common +-- Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009 +-- +-- License : BSD-style +-- Maintainer : rtharper@aftereternity.co.uk, bos@serpentine.com, +-- duncan@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Fusible 'Stream'-oriented functions for converting between 'Text' +-- and several common encodings. + +module Data.Text.Encoding.Fusion.Common + ( + -- * Restreaming + -- Restreaming is the act of converting from one 'Stream' + -- representation to another. + restreamUtf8 + , restreamUtf16LE + , restreamUtf16BE + , restreamUtf32LE + , restreamUtf32BE + ) where + +import Data.Bits (shiftR, (.&.)) +import Data.Char (ord) +import Data.Text.Fusion (Step(..), Stream(..)) +import Data.Text.Fusion.Internal (M(..), S(..)) +import Data.Word (Word8) +import qualified Data.Text.Encoding.Utf8 as U8 + +-- | /O(n)/ Convert a Stream Char into a UTF-8 encoded Stream Word8. +restreamUtf8 :: Stream Char -> Stream Word8 +restreamUtf8 (Stream next0 s0 len) = + Stream next (S s0 N N N) (len*2) + where + {-# INLINE next #-} + next (S s N N N) = case next0 s of + Done -> Done + Skip s' -> Skip (S s' N N N) + Yield x xs + | n <= 0x7F -> Yield c (S xs N N N) + | n <= 0x07FF -> Yield a2 (S xs (J b2) N N) + | n <= 0xFFFF -> Yield a3 (S xs (J b3) (J c3) N) + | otherwise -> Yield a4 (S xs (J b4) (J c4) (J d4)) + where + n = ord x + c = fromIntegral n + (a2,b2) = U8.ord2 x + (a3,b3,c3) = U8.ord3 x + (a4,b4,c4,d4) = U8.ord4 x + next (S s (J x2) N N) = Yield x2 (S s N N N) + next (S s (J x2) x3 N) = Yield x2 (S s x3 N N) + next (S s (J x2) x3 x4) = Yield x2 (S s x3 x4 N) + next _ = internalError "restreamUtf8" +{-# INLINE restreamUtf8 #-} + +restreamUtf16BE :: Stream Char -> Stream Word8 +restreamUtf16BE (Stream next0 s0 len) = + Stream next (S s0 N N N) (len*2) + where + {-# INLINE next #-} + next (S s N N N) = case next0 s of + Done -> Done + Skip s' -> Skip (S s' N N N) + Yield x xs + | n < 0x10000 -> Yield (fromIntegral $ n `shiftR` 8) $ + S xs (J $ fromIntegral n) N N + | otherwise -> Yield c1 $ + S xs (J c2) (J c3) (J c4) + where + n = ord x + n1 = n - 0x10000 + c1 = fromIntegral (n1 `shiftR` 18 + 0xD8) + c2 = fromIntegral (n1 `shiftR` 10) + n2 = n1 .&. 0x3FF + c3 = fromIntegral (n2 `shiftR` 8 + 0xDC) + c4 = fromIntegral n2 + next (S s (J x2) N N) = Yield x2 (S s N N N) + next (S s (J x2) x3 N) = Yield x2 (S s x3 N N) + next (S s (J x2) x3 x4) = Yield x2 (S s x3 x4 N) + next _ = internalError "restreamUtf16BE" +{-# INLINE restreamUtf16BE #-} + +restreamUtf16LE :: Stream Char -> Stream Word8 +restreamUtf16LE (Stream next0 s0 len) = + Stream next (S s0 N N N) (len*2) + where + {-# INLINE next #-} + next (S s N N N) = case next0 s of + Done -> Done + Skip s' -> Skip (S s' N N N) + Yield x xs + | n < 0x10000 -> Yield (fromIntegral n) $ + S xs (J (fromIntegral $ shiftR n 8)) N N + | otherwise -> Yield c1 $ + S xs (J c2) (J c3) (J c4) + where + n = ord x + n1 = n - 0x10000 + c2 = fromIntegral (shiftR n1 18 + 0xD8) + c1 = fromIntegral (shiftR n1 10) + n2 = n1 .&. 0x3FF + c4 = fromIntegral (shiftR n2 8 + 0xDC) + c3 = fromIntegral n2 + next (S s (J x2) N N) = Yield x2 (S s N N N) + next (S s (J x2) x3 N) = Yield x2 (S s x3 N N) + next (S s (J x2) x3 x4) = Yield x2 (S s x3 x4 N) + next _ = internalError "restreamUtf16LE" +{-# INLINE restreamUtf16LE #-} + +restreamUtf32BE :: Stream Char -> Stream Word8 +restreamUtf32BE (Stream next0 s0 len) = + Stream next (S s0 N N N) (len*2) + where + {-# INLINE next #-} + next (S s N N N) = case next0 s of + Done -> Done + Skip s' -> Skip (S s' N N N) + Yield x xs -> Yield c1 (S xs (J c2) (J c3) (J c4)) + where + n = ord x + c1 = fromIntegral $ shiftR n 24 + c2 = fromIntegral $ shiftR n 16 + c3 = fromIntegral $ shiftR n 8 + c4 = fromIntegral n + next (S s (J x2) N N) = Yield x2 (S s N N N) + next (S s (J x2) x3 N) = Yield x2 (S s x3 N N) + next (S s (J x2) x3 x4) = Yield x2 (S s x3 x4 N) + next _ = internalError "restreamUtf32BE" +{-# INLINE restreamUtf32BE #-} + +restreamUtf32LE :: Stream Char -> Stream Word8 +restreamUtf32LE (Stream next0 s0 len) = + Stream next (S s0 N N N) (len*2) + where + {-# INLINE next #-} + next (S s N N N) = case next0 s of + Done -> Done + Skip s' -> Skip (S s' N N N) + Yield x xs -> Yield c1 (S xs (J c2) (J c3) (J c4)) + where + n = ord x + c4 = fromIntegral $ shiftR n 24 + c3 = fromIntegral $ shiftR n 16 + c2 = fromIntegral $ shiftR n 8 + c1 = fromIntegral n + next (S s (J x2) N N) = Yield x2 (S s N N N) + next (S s (J x2) x3 N) = Yield x2 (S s x3 N N) + next (S s (J x2) x3 x4) = Yield x2 (S s x3 x4 N) + next _ = internalError "restreamUtf32LE" +{-# INLINE restreamUtf32LE #-} + +internalError :: String -> a +internalError func = + error $ "Data.Text.Encoding.Fusion.Common." ++ func ++ ": internal error" diff --git a/Data/Text/Foreign.hs b/Data/Text/Foreign.hs --- a/Data/Text/Foreign.hs +++ b/Data/Text/Foreign.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Bryan O'Sullivan 2009 -- -- License : BSD-style --- Maintainer : rtharper@aftereternity.co.uk, bos@serpentine.com, +-- Maintainer : bos@serpentine.com, rtharper@aftereternity.co.uk, -- duncan@haskell.org -- Stability : experimental -- Portability : GHC diff --git a/Data/Text/Fusion.hs b/Data/Text/Fusion.hs --- a/Data/Text/Fusion.hs +++ b/Data/Text/Fusion.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, BangPatterns, MagicHash #-} +{-# LANGUAGE BangPatterns, MagicHash #-} -- | -- Module : Data.Text.Fusion @@ -7,7 +7,7 @@ -- (c) Duncan Coutts 2009 -- -- License : BSD-style --- Maintainer : rtharper@aftereternity.co.uk, bos@serpentine.com, +-- Maintainer : bos@serpentine.com, rtharper@aftereternity.co.uk, -- duncan@haskell.org -- Stability : experimental -- Portability : GHC @@ -24,72 +24,20 @@ , stream , unstream , reverseStream - , empty - -- * Basic interface - , cons - , snoc - , append - , uncons - , head - , tail - , last - , init - , null , length - , eq -- * Transformations - , map - , intercalate - , intersperse , reverse - -- * Folds - , foldl - , foldl' - , foldl1 - , foldl1' - , foldr - , foldr1 - - -- ** Special folds - , concat - , concatMap - , any - , all - , maximum - , minimum - -- * Construction -- ** Scans - , scanl , reverseScanr - -- ** Accumulating maps - , mapAccumL - -- ** Generation and unfolding - , replicate - , unfoldr , unfoldrN - -- * Substrings - -- ** Breaking strings - , take - , drop - , takeWhile - , dropWhile - - -- * Predicates - , isPrefixOf - - -- * Searching - , elem - , filter - -- * Indexing - , find , index , findIndex , findIndices @@ -97,57 +45,24 @@ , elemIndex , elemIndices , count - - -- * Zipping and unzipping - , zipWith ) where -import Prelude (Bool(..), Char, Either(..), Eq(..), Maybe(..), Monad(..), - Num(..), Ord(..), String, ($), (++), (.), (&&), +import Prelude (Bool(..), Char, Eq(..), Maybe(..), Monad(..), Int, + Num(..), Ord(..), ($), (&&), fromIntegral, otherwise) -import Control.Monad (liftM2) -import Control.Monad.ST (runST) -import qualified Data.List as L -import GHC.Exts (Int(..), (+#)) import Data.Bits ((.&.), shiftR) import Data.Char (ord) import Data.Text.Internal (Text(..)) -import Data.Text.UnsafeChar (unsafeChr, unsafeWrite, unsafeWriteRev) +import Data.Text.UnsafeChar (unsafeChr, unsafeWrite) import qualified Data.Text.Array as A +import qualified Data.Text.Fusion.Common as S +import Data.Text.Fusion.Internal import qualified Data.Text.Internal as I import qualified Data.Text.Encoding.Utf16 as U16 import qualified Prelude as P default(Int) -infixl 2 :!: -data PairS a b = !a :!: !b - --- | Allow a function over a stream to switch between two states. -data Switch = S1 | S2 - -data Stream a = - forall s. Stream - (s -> Step s a) -- stepper function - !s -- current state - {-# UNPACK #-}!Int -- length hint - --- The length hint in a Stream has two roles. If its value is zero, --- we trust it, and treat the stream as empty. Otherwise, we treat it --- as a hint: it should usually be accurate, so we use it when --- unstreaming to decide what size array to allocate. However, the --- unstreaming functions must be able to cope with the hint being too --- small or too large. --- --- The size hint tries to track the UTF-16 code points in a stream, --- but often counts the number of characters instead. It can easily --- undercount if, for instance, a transformed stream contains astral --- plane characters (those above 0x10000). - -data Step s a = Done - | Skip !s - | Yield !a !s - -- | /O(n)/ Convert a 'Text' into a 'Stream Char'. stream :: Text -> Stream Char stream (Text arr off len) = Stream next off len @@ -178,235 +93,42 @@ n2 = A.unsafeIndex arr (i - 1) {-# INLINE [0] reverseStream #-} --- | /O(n)/ Convert a Stream Char into a Text. +-- | /O(n)/ Convert a 'Stream Char' into a 'Text'. unstream :: Stream Char -> Text unstream (Stream next0 s0 len) - | len == 0 = I.empty - | otherwise = Text (P.fst a) 0 (P.snd a) + | len == 0 = I.empty + | otherwise = I.textP (P.fst a) 0 (P.snd a) where - a = runST (A.unsafeNew len >>= (\arr -> loop arr len s0 0)) + a = A.run2 (A.unsafeNew len >>= (\arr -> loop arr len s0 0)) loop arr !top !s !i | i + 1 >= top = case next0 s of - Done -> liftM2 (,) (A.unsafeFreeze arr) (return i) + Done -> return (arr, i) _ -> do arr' <- A.unsafeNew (top*2) A.copy arr arr' >> loop arr' (top*2) s i | otherwise = case next0 s of - Done -> liftM2 (,) (A.unsafeFreeze arr) (return i) + Done -> return (arr, i) Skip s' -> loop arr top s' i Yield x s' -> unsafeWrite arr i x >>= loop arr top s' {-# INLINE [0] unstream #-} {-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-} --- | The empty stream. -empty :: Stream Char -empty = Stream next () 0 - where next _ = Done -{-# INLINE [0] empty #-} --- | /O(n)/ Determines if two streams are equal. -eq :: Ord a => Stream a -> Stream a -> Bool -eq (Stream next1 s1 _) (Stream next2 s2 _) = cmp (next1 s1) (next2 s2) - where - cmp Done Done = True - cmp Done _ = False - cmp _ Done = False - cmp (Skip s1') (Skip s2') = cmp (next1 s1') (next2 s2') - cmp (Skip s1') x2 = cmp (next1 s1') x2 - cmp x1 (Skip s2') = cmp x1 (next2 s2') - cmp (Yield x1 s1') (Yield x2 s2') = x1 == x2 && - cmp (next1 s1') (next2 s2') -{-# SPECIALISE eq :: Stream Char -> Stream Char -> Bool #-} - -streamError :: String -> String -> a -streamError func msg = P.error $ "Data.Text.Fusion." ++ func ++ ": " ++ msg - -internalError :: String -> a -internalError func = streamError func "Internal error" - -emptyError :: String -> a -emptyError func = internalError func "Empty input" - -- ---------------------------------------------------------------------------- -- * Basic stream functions --- | /O(n)/ Adds a character to the front of a Stream Char. -cons :: Char -> Stream Char -> Stream Char -cons w (Stream next0 s0 len) = Stream next (S2 :!: s0) (len+2) - where - {-# INLINE next #-} - next (S2 :!: s) = Yield w (S1 :!: s) - next (S1 :!: s) = case next0 s of - Done -> Done - Skip s' -> Skip (S1 :!: s') - Yield x s' -> Yield x (S1 :!: s') -{-# INLINE [0] cons #-} - --- | /O(n)/ Adds a character to the end of a stream. -snoc :: Stream Char -> Char -> Stream Char -snoc (Stream next0 xs0 len) w = Stream next (Just xs0) (len+2) - where - {-# INLINE next #-} - next (Just xs) = case next0 xs of - Done -> Yield w Nothing - Skip xs' -> Skip (Just xs') - Yield x xs' -> Yield x (Just xs') - next Nothing = Done -{-# INLINE [0] snoc #-} - --- | /O(n)/ Appends one Stream to the other. -append :: Stream Char -> Stream Char -> Stream Char -append (Stream next0 s01 len1) (Stream next1 s02 len2) = - Stream next (Left s01) (len1 + len2) - where - {-# INLINE next #-} - next (Left s1) = case next0 s1 of - Done -> Skip (Right s02) - Skip s1' -> Skip (Left s1') - Yield x s1' -> Yield x (Left s1') - next (Right s2) = case next1 s2 of - Done -> Done - Skip s2' -> Skip (Right s2') - Yield x s2' -> Yield x (Right s2') -{-# INLINE [0] append #-} - --- | /O(1)/ Returns the first character of a Text, which must be non-empty. --- Subject to array fusion. -head :: Stream Char -> Char -head (Stream next s0 _len) = loop_head s0 - where - loop_head !s = case next s of - Yield x _ -> x - Skip s' -> loop_head s' - Done -> streamError "head" "Empty stream" -{-# INLINE [0] head #-} - --- | /O(1)/ Returns the first character and remainder of a 'Stream --- Char', or 'Nothing' if empty. Subject to array fusion. -uncons :: Stream Char -> Maybe (Char, Stream Char) -uncons (Stream next s0 len) = loop_uncons s0 - where - loop_uncons !s = case next s of - Yield x s1 -> Just (x, Stream next s1 (len-1)) - Skip s' -> loop_uncons s' - Done -> Nothing -{-# INLINE [0] uncons #-} - --- | /O(n)/ Returns the last character of a 'Stream Char', which must --- be non-empty. -last :: Stream Char -> Char -last (Stream next s0 _len) = loop0_last s0 - where - loop0_last !s = case next s of - Done -> emptyError "last" - Skip s' -> loop0_last s' - Yield x s' -> loop_last x s' - loop_last !x !s = case next s of - Done -> x - Skip s' -> loop_last x s' - Yield x' s' -> loop_last x' s' -{-# INLINE[0] last #-} - --- | /O(1)/ Returns all characters after the head of a Stream Char, which must --- be non-empty. -tail :: Stream Char -> Stream Char -tail (Stream next0 s0 len) = Stream next (False :!: s0) (len-1) - where - {-# INLINE next #-} - next (False :!: s) = case next0 s of - Done -> emptyError "tail" - Skip s' -> Skip (False :!: s') - Yield _ s' -> Skip (True :!: s') - next (True :!: s) = case next0 s of - Done -> Done - Skip s' -> Skip (True :!: s') - Yield x s' -> Yield x (True :!: s') -{-# INLINE [0] tail #-} - - --- | /O(1)/ Returns all but the last character of a Stream Char, which --- must be non-empty. -init :: Stream Char -> Stream Char -init (Stream next0 s0 len) = Stream next (Nothing :!: s0) (len-1) - where - {-# INLINE next #-} - next (Nothing :!: s) = case next0 s of - Done -> emptyError "init" - Skip s' -> Skip (Nothing :!: s') - Yield x s' -> Skip (Just x :!: s') - next (Just x :!: s) = case next0 s of - Done -> Done - Skip s' -> Skip (Just x :!: s') - Yield x' s' -> Yield x (Just x' :!: s') -{-# INLINE [0] init #-} - --- | /O(1)/ Tests whether a Stream Char is empty or not. -null :: Stream Char -> Bool -null (Stream next s0 _len) = loop_null s0 - where - loop_null !s = case next s of - Done -> True - Yield _ _ -> False - Skip s' -> loop_null s' -{-# INLINE[0] null #-} - --- | /O(n)/ Returns the number of characters in a text. length :: Stream Char -> Int -length (Stream next s0 _len) = loop_length 0# s0 - where - - loop_length z# s = case next s of - Done -> (I# z#) - Skip s' -> loop_length z# s' - Yield _ s' -> loop_length (z# +# 1#) s' +length = S.lengthI {-# INLINE[0] length #-} --- ---------------------------------------------------------------------------- --- * Stream transformations - --- | /O(n)/ 'map' @f @xs is the Stream Char obtained by applying @f@ to each element of --- @xs@. -map :: (Char -> Char) -> Stream Char -> Stream Char -map f (Stream next0 s0 len) = Stream next s0 len - where - {-# INLINE next #-} - next !s = case next0 s of - Done -> Done - Skip s' -> Skip s' - Yield x s' -> Yield (f x) s' -{-# INLINE [0] map #-} - -{-# - RULES "STREAM map/map fusion" forall f g s. - map f (map g s) = map (\x -> f (g x)) s - #-} - --- | /O(n)/ Take a character and place it between each of the --- characters of a 'Stream Char'. -intersperse :: Char -> Stream Char -> Stream Char -intersperse c (Stream next0 s0 len) = Stream next (s0 :!: Nothing :!: S1) len - where - {-# INLINE next #-} - next (s :!: Nothing :!: S1) = case next0 s of - Done -> Done - Skip s' -> Skip (s' :!: Nothing :!: S1) - Yield x s' -> Skip (s' :!: Just x :!: S1) - next (s :!: Just x :!: S1) = Yield x (s :!: Nothing :!: S2) - next (s :!: Nothing :!: S2) = case next0 s of - Done -> Done - Skip s' -> Skip (s' :!: Nothing :!: S2) - Yield x s' -> Yield c (s' :!: Just x :!: S1) - next _ = internalError "intersperse" -{-# INLINE [0] intersperse #-} - -- | /O(n)/ Reverse the characters of a string. reverse :: Stream Char -> Text reverse (Stream next s len0) | len0 == 0 = I.empty - | otherwise = Text arr off' len' + | otherwise = I.textP arr off' len' where len0' = max len0 4 - (arr, (off', len')) = A.run2 (A.unsafeNew len0 >>= loop s (len0'-1) len0') + (arr, (off', len')) = A.run2 (A.unsafeNew len0' >>= loop s (len0'-1) len0') loop !s0 !i !len marr = case next s0 of Done -> return (marr, (j, len-j)) @@ -424,195 +146,20 @@ m = n - 0x10000 lo = fromIntegral $ (m `shiftR` 10) + 0xD800 hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00 - write s i len marr + write t j l mar | n < 0x10000 = do - A.unsafeWrite marr i (fromIntegral n) - loop s (i-1) len marr + A.unsafeWrite mar j (fromIntegral n) + loop t (j-1) l mar | otherwise = do - A.unsafeWrite marr (i-1) lo - A.unsafeWrite marr i hi - loop s (i-2) len marr + A.unsafeWrite mar (j-1) lo + A.unsafeWrite mar j hi + loop t (j-2) l mar {-# INLINE [0] reverse #-} --- ---------------------------------------------------------------------------- --- * Reducing Streams (folds) - --- | foldl, applied to a binary operator, a starting value (typically the --- left-identity of the operator), and a Stream, reduces the Stream using the --- binary operator, from left to right. -foldl :: (b -> Char -> b) -> b -> Stream Char -> b -foldl f z0 (Stream next s0 _len) = loop_foldl z0 s0 - where - loop_foldl z !s = case next s of - Done -> z - Skip s' -> loop_foldl z s' - Yield x s' -> loop_foldl (f z x) s' -{-# INLINE [0] foldl #-} - --- | A strict version of foldl. -foldl' :: (b -> Char -> b) -> b -> Stream Char -> b -foldl' f z0 (Stream next s0 _len) = loop_foldl' z0 s0 - where - loop_foldl' !z !s = case next s of - Done -> z - Skip s' -> loop_foldl' z s' - Yield x s' -> loop_foldl' (f z x) s' -{-# INLINE [0] foldl' #-} - --- | foldl1 is a variant of foldl that has no starting value argument, --- and thus must be applied to non-empty Streams. -foldl1 :: (Char -> Char -> Char) -> Stream Char -> Char -foldl1 f (Stream next s0 _len) = loop0_foldl1 s0 - where - loop0_foldl1 !s = case next s of - Skip s' -> loop0_foldl1 s' - Yield x s' -> loop_foldl1 x s' - Done -> emptyError "foldl1" - loop_foldl1 z !s = case next s of - Done -> z - Skip s' -> loop_foldl1 z s' - Yield x s' -> loop_foldl1 (f z x) s' -{-# INLINE [0] foldl1 #-} - --- | A strict version of foldl1. -foldl1' :: (Char -> Char -> Char) -> Stream Char -> Char -foldl1' f (Stream next s0 _len) = loop0_foldl1' s0 - where - loop0_foldl1' !s = case next s of - Skip s' -> loop0_foldl1' s' - Yield x s' -> loop_foldl1' x s' - Done -> emptyError "foldl1" - loop_foldl1' !z !s = case next s of - Done -> z - Skip s' -> loop_foldl1' z s' - Yield x s' -> loop_foldl1' (f z x) s' -{-# INLINE [0] foldl1' #-} - --- | 'foldr', applied to a binary operator, a starting value (typically the --- right-identity of the operator), and a stream, reduces the stream using the --- binary operator, from right to left. -foldr :: (Char -> b -> b) -> b -> Stream Char -> b -foldr f z (Stream next s0 _len) = loop_foldr s0 - where - loop_foldr !s = case next s of - Done -> z - Skip s' -> loop_foldr s' - Yield x s' -> f x (loop_foldr s') -{-# INLINE [0] foldr #-} - --- | foldr1 is a variant of 'foldr' that has no starting value argument, --- and thus must be applied to non-empty streams. --- Subject to array fusion. -foldr1 :: (Char -> Char -> Char) -> Stream Char -> Char -foldr1 f (Stream next s0 _len) = loop0_foldr1 s0 - where - loop0_foldr1 !s = case next s of - Done -> emptyError "foldr1" - Skip s' -> loop0_foldr1 s' - Yield x s' -> loop_foldr1 x s' - - loop_foldr1 x !s = case next s of - Done -> x - Skip s' -> loop_foldr1 x s' - Yield x' s' -> f x (loop_foldr1 x' s') -{-# INLINE [0] foldr1 #-} - -intercalate :: Stream Char -> [Stream Char] -> Stream Char -intercalate s = concat . (L.intersperse s) -{-# INLINE [0] intercalate #-} - --- ---------------------------------------------------------------------------- --- ** Special folds - --- | /O(n)/ Concatenate a list of streams. Subject to array fusion. -concat :: [Stream Char] -> Stream Char -concat = L.foldr append (Stream next Done 0) - where - next Done = Done - next _ = internalError "concat" - --- | Map a function over a stream that results in a stream and concatenate the --- results. -concatMap :: (Char -> Stream Char) -> Stream Char -> Stream Char -concatMap f = foldr (append . f) empty - --- | /O(n)/ any @p @xs determines if any character in the stream --- @xs@ satisifes the predicate @p@. -any :: (Char -> Bool) -> Stream Char -> Bool -any p (Stream next0 s0 _len) = loop_any s0 - where - loop_any !s = case next0 s of - Done -> False - Skip s' -> loop_any s' - Yield x s' | p x -> True - | otherwise -> loop_any s' -{-# INLINE [0] any #-} - --- | /O(n)/ all @p @xs determines if all characters in the 'Text' --- @xs@ satisify the predicate @p@. -all :: (Char -> Bool) -> Stream Char -> Bool -all p (Stream next0 s0 _len) = loop_all s0 - where - loop_all !s = case next0 s of - Done -> True - Skip s' -> loop_all s' - Yield x s' | p x -> loop_all s' - | otherwise -> False -{-# INLINE [0] all #-} - --- | /O(n)/ maximum returns the maximum value from a stream, which must be --- non-empty. -maximum :: Stream Char -> Char -maximum (Stream next0 s0 _len) = loop0_maximum s0 - where - loop0_maximum !s = case next0 s of - Done -> emptyError "maximum" - Skip s' -> loop0_maximum s' - Yield x s' -> loop_maximum x s' - loop_maximum !z !s = case next0 s of - Done -> z - Skip s' -> loop_maximum z s' - Yield x s' - | x > z -> loop_maximum x s' - | otherwise -> loop_maximum z s' -{-# INLINE [0] maximum #-} - --- | /O(n)/ minimum returns the minimum value from a 'Text', which must be --- non-empty. -minimum :: Stream Char -> Char -minimum (Stream next0 s0 _len) = loop0_minimum s0 - where - loop0_minimum !s = case next0 s of - Done -> emptyError "minimum" - Skip s' -> loop0_minimum s' - Yield x s' -> loop_minimum x s' - loop_minimum !z !s = case next0 s of - Done -> z - Skip s' -> loop_minimum z s' - Yield x s' - | x < z -> loop_minimum x s' - | otherwise -> loop_minimum z s' -{-# INLINE [0] minimum #-} - --- ----------------------------------------------------------------------------- --- * Building streams - -scanl :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char -scanl f z0 (Stream next0 s0 len) = Stream next (S1 :!: z0 :!: s0) (len+1) - where - {-# INLINE next #-} - next (S1 :!: z :!: s) = Yield z (S2 :!: z :!: s) - next (S2 :!: z :!: s) = case next0 s of - Yield x s' -> let !x' = f z x - in Yield x' (S2 :!: x' :!: s') - Skip s' -> Skip (S2 :!: z :!: s') - Done -> Done -{-# INLINE [0] scanl #-} - -- | /O(n)/ Perform the equivalent of 'scanr' over a list, only with -- the input and result reversed. reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char -reverseScanr f z0 (Stream next0 s0 len) = Stream next (S1 :!: z0 :!: s0) (len+1) +reverseScanr f z0 (Stream next0 s0 len) = Stream next (S1 :!: z0 :!: s0) (len+1) -- HINT maybe too low where {-# INLINE next #-} next (S1 :!: z :!: s) = Yield z (S2 :!: z :!: s) @@ -623,237 +170,34 @@ Done -> Done {-# INLINE reverseScanr #-} --- ----------------------------------------------------------------------------- --- ** Accumulating maps - --- | /O(n)/ Like a combination of 'map' and 'foldl'. Applies a --- function to each element of a stream, passing an accumulating --- parameter from left to right, and returns a final stream. --- --- /Note/: Unlike the version over lists, this function does not --- return a final value for the accumulator, because the nature of --- streams precludes it. -mapAccumL :: (a -> b -> (a,b)) -> a -> Stream b -> Stream b -mapAccumL f z0 (Stream next0 s0 len) = Stream next (s0 :!: z0) len - where - {-# INLINE next #-} - next (s :!: z) = case next0 s of - Yield x s' -> let (z',y) = f z x - in Yield y (s' :!: z') - Skip s' -> Skip (s' :!: z) - Done -> Done -{-# INLINE [0] mapAccumL #-} - --- ----------------------------------------------------------------------------- --- ** Generating and unfolding streams - -replicate :: Int -> Char -> Stream Char -replicate n c - | n < 0 = empty - | otherwise = Stream next 0 n - where - {-# INLINE next #-} - next i | i >= n = Done - | otherwise = Yield c (i + 1) -{-# INLINE [0] replicate #-} - --- | /O(n)/, where @n@ is the length of the result. The unfoldr function --- is analogous to the List 'unfoldr'. unfoldr builds a stream --- from a seed value. The function takes the element and returns --- Nothing if it is done producing the stream or returns Just --- (a,b), in which case, a is the next Char in the string, and b is --- the seed value for further production. -unfoldr :: (a -> Maybe (Char,a)) -> a -> Stream Char -unfoldr f s0 = Stream next s0 1 - where - {-# INLINE next #-} - next !s = case f s of - Nothing -> Done - Just (w, s') -> Yield w s' -{-# INLINE [0] unfoldr #-} - -- | /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 'unfoldrN'. This function is more efficient than -- 'unfoldr' when the length of the result is known. unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char -unfoldrN n f s0 | n < 0 = empty - | otherwise = Stream next (0 :!: s0) (n*2) - where - {-# INLINE next #-} - next (z :!: s) = case f s of - Nothing -> Done - Just (w, s') | z >= n -> Done - | otherwise -> Yield w ((z + 1) :!: s') -------------------------------------------------------------------------------- --- * Substreams - --- | /O(n)/ take n, applied to a stream, returns the prefix of the --- stream of length @n@, or the stream itself if @n@ is greater than the --- length of the stream. -take :: Int -> Stream Char -> Stream Char -take n0 (Stream next0 s0 len) = Stream next (n0 :!: s0) len - where - {-# INLINE next #-} - next (n :!: s) | n <= 0 = Done - | otherwise = case next0 s of - Done -> Done - Skip s' -> Skip (n :!: s') - Yield x s' -> Yield x ((n-1) :!: s') -{-# 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. -drop :: Int -> Stream Char -> Stream Char -drop n0 (Stream next0 s0 len) = Stream next (Just ((max 0 n0)) :!: s0) (len - n0) - where - {-# INLINE next #-} - next (Just !n :!: s) - | n == 0 = Skip (Nothing :!: s) - | otherwise = case next0 s of - Done -> Done - Skip s' -> Skip (Just n :!: s') - Yield _ s' -> Skip (Just (n-1) :!: s') - next (Nothing :!: s) = case next0 s of - Done -> Done - Skip s' -> Skip (Nothing :!: s') - Yield x s' -> Yield x (Nothing :!: s') -{-# INLINE [0] drop #-} - --- | takeWhile, applied to a predicate @p@ and a stream, returns the --- longest prefix (possibly empty) of elements that satisfy p. -takeWhile :: (Char -> Bool) -> Stream Char -> Stream Char -takeWhile p (Stream next0 s0 len) = Stream next s0 len - where - {-# INLINE next #-} - next !s = case next0 s of - Done -> Done - Skip s' -> Skip s' - Yield x s' | p x -> Yield x s' - | otherwise -> Done -{-# INLINE [0] takeWhile #-} - --- | dropWhile @p @xs returns the suffix remaining after takeWhile @p @xs. -dropWhile :: (Char -> Bool) -> Stream Char -> Stream Char -dropWhile p (Stream next0 s0 len) = Stream next (S1 :!: s0) len - where - {-# INLINE next #-} - next (S1 :!: s) = case next0 s of - Done -> Done - Skip s' -> Skip (S1 :!: s') - Yield x s' | p x -> Skip (S1 :!: s') - | otherwise -> Yield x (S2 :!: s') - next (S2 :!: s) = case next0 s of - Done -> Done - Skip s' -> Skip (S2 :!: s') - Yield x s' -> Yield x (S2 :!: s') -{-# INLINE [0] dropWhile #-} - --- | /O(n)/ The 'isPrefixOf' function takes two 'Stream's and returns --- 'True' iff the first is a prefix of the second. -isPrefixOf :: (Eq a) => Stream a -> Stream a -> Bool -isPrefixOf (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2) - where - loop Done _ = True - loop _ Done = False - loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2') - loop (Skip s1') x2 = loop (next1 s1') x2 - loop x1 (Skip s2') = loop x1 (next2 s2') - loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 && - loop (next1 s1') (next2 s2') -{-# INLINE [0] isPrefixOf #-} -{-# SPECIALISE isPrefixOf :: Stream Char -> Stream Char -> Bool #-} - --- ---------------------------------------------------------------------------- --- * Searching - -------------------------------------------------------------------------------- --- ** Searching by equality - --- | /O(n)/ elem is the stream membership predicate. -elem :: Char -> Stream Char -> Bool -elem w (Stream next s0 _len) = loop_elem s0 - where - loop_elem !s = case next s of - Done -> False - Skip s' -> loop_elem s' - Yield x s' | x == w -> True - | otherwise -> loop_elem s' -{-# INLINE [0] elem #-} - -------------------------------------------------------------------------------- --- ** Searching with a predicate - --- | /O(n)/ The 'find' function takes a predicate and a stream, --- and returns the first element in matching the predicate, or 'Nothing' --- if there is no such element. - -find :: (Char -> Bool) -> Stream Char -> Maybe Char -find p (Stream next s0 _len) = loop_find s0 - where - loop_find !s = case next s of - Done -> Nothing - Skip s' -> loop_find s' - Yield x s' | p x -> Just x - | otherwise -> loop_find s' -{-# INLINE [0] find #-} - --- | /O(n)/ 'filter', applied to a predicate and a stream, --- returns a stream containing those characters that satisfy the --- predicate. -filter :: (Char -> Bool) -> Stream Char -> Stream Char -filter p (Stream next0 s0 len) = Stream next s0 len - where - {-# INLINE next #-} - next !s = case next0 s of - Done -> Done - Skip s' -> Skip s' - Yield x s' | p x -> Yield x s' - | otherwise -> Skip s' -{-# INLINE [0] filter #-} - -{-# RULES - "Stream filter/filter fusion" forall p q s. - filter p (filter q s) = filter (\x -> q x && p x) s - #-} +unfoldrN n = S.unfoldrNI n +{-# INLINE [0] unfoldrN #-} ------------------------------------------------------------------------------- -- ** Indexing streams --- | /O(1)/ stream index (subscript) operator, starting from 0. +-- | /O(n)/ stream index (subscript) operator, starting from 0. index :: Stream Char -> Int -> Char -index (Stream next s0 _len) n0 - | n0 < 0 = streamError "index" "Negative index" - | otherwise = loop_index n0 s0 - where - loop_index !n !s = case next s of - Done -> streamError "index" "Index too large" - Skip s' -> loop_index n s' - Yield x s' | n == 0 -> x - | otherwise -> loop_index (n-1) s' +index = S.indexI {-# INLINE [0] index #-} -- | The 'findIndex' function takes a predicate and a stream and -- returns the index of the first element in the stream -- satisfying the predicate. findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int -findIndex p s = case findIndices p s of - (i:_) -> Just i - _ -> Nothing +findIndex = S.findIndexI {-# INLINE [0] findIndex #-} -- | The 'findIndices' function takes a predicate and a stream and -- returns all indices of the elements in the stream -- satisfying the predicate. findIndices :: (Char -> Bool) -> Stream Char -> [Int] -findIndices p (Stream next s0 _len) = loop_findIndex 0 s0 - where - loop_findIndex !i !s = case next s of - Done -> [] - Skip s' -> loop_findIndex i s' -- hmm. not caught by QC - Yield x s' | p x -> i : loop_findIndex (i+1) s' - | otherwise -> loop_findIndex (i+1) s' +findIndices = S.findIndicesI {-# INLINE [0] findIndices #-} -- | The 'findIndexOrEnd' function takes a predicate and a stream and @@ -873,51 +217,17 @@ -- element in the given stream which is equal to the query -- element, or 'Nothing' if there is no such element. elemIndex :: Char -> Stream Char -> Maybe Int -elemIndex a s = case elemIndices a s of - (i:_) -> Just i - _ -> Nothing +elemIndex = S.elemIndexI {-# INLINE [0] elemIndex #-} -- | /O(n)/ The 'elemIndices' function returns the index of every -- element in the given stream which is equal to the query element. elemIndices :: Char -> Stream Char -> [Int] -elemIndices a (Stream next s0 _len) = loop 0 s0 - where - loop !i !s = case next s of - Done -> [] - Skip s' -> loop i s' - Yield x s' | a == x -> i : loop (i+1) s' - | otherwise -> loop (i+1) s' +elemIndices = S.elemIndicesI {-# INLINE [0] elemIndices #-} -- | /O(n)/ The 'count' function returns the number of times the query -- element appears in the given stream. count :: Char -> Stream Char -> Int -count a (Stream next s0 _len) = loop 0 s0 - where - loop !i !s = case next s of - Done -> i - Skip s' -> loop i s' - Yield x s' | a == x -> loop (i+1) s' - | otherwise -> loop i s' +count = S.countI {-# INLINE [0] count #-} - -------------------------------------------------------------------------------- --- * Zipping - --- | zipWith generalises 'zip' by zipping with the function given as --- the first argument, instead of a tupling function. -zipWith :: (Char -> Char -> Char) -> Stream Char -> Stream Char -> Stream Char -zipWith f (Stream next0 sa0 len1) (Stream next1 sb0 len2) = Stream next (sa0 :!: sb0 :!: Nothing) (min len1 len2) - where - {-# INLINE next #-} - next (sa :!: sb :!: Nothing) = case next0 sa of - Done -> Done - Skip sa' -> Skip (sa' :!: sb :!: Nothing) - Yield a sa' -> Skip (sa' :!: sb :!: Just a) - - next (sa' :!: sb :!: Just a) = case next1 sb of - Done -> Done - Skip sb' -> Skip (sa' :!: sb' :!: Just a) - Yield b sb' -> Yield (f a b) (sa' :!: sb' :!: Nothing) -{-# INLINE [0] zipWith #-} diff --git a/Data/Text/Fusion/Common.hs b/Data/Text/Fusion/Common.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Fusion/Common.hs @@ -0,0 +1,760 @@ +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Data.Text.Fusion.Common +-- Copyright : (c) Bryan O'Sullivan 2009 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com, rtharper@aftereternity.co.uk, +-- duncan@haskell.org +-- Stability : experimental +-- Portability : GHC +-- +-- Common stream fusion functionality for text. + +module Data.Text.Fusion.Common + ( + -- * Creation and elimination + singleton + , streamList + , unstreamList + + -- * Basic interface + , cons + , snoc + , append + , head + , uncons + , last + , tail + , init + , null + , lengthI + + -- * Transformations + , map + , intercalate + , intersperse + + -- * Folds + , foldl + , foldl' + , foldl1 + , foldl1' + , foldr + , foldr1 + + -- ** Special folds + , concat + , concatMap + , any + , all + , maximum + , minimum + + -- * Construction + -- ** Scans + , scanl + + -- ** Accumulating maps + , mapAccumL + + -- ** Generation and unfolding + , replicate + , unfoldr + , unfoldrNI + + -- * Substrings + -- ** Breaking strings + , take + , drop + , takeWhile + , dropWhile + + -- * Predicates + , isPrefixOf + + -- * Searching + , elem + , filter + + -- * Indexing + , find + , indexI + , findIndexI + , findIndicesI + , elemIndexI + , elemIndicesI + , countI + + -- * Zipping and unzipping + , zipWith + ) where + +import Prelude (Bool(..), Char, Either(..), Eq(..), Int, Integral, Maybe(..), + Ord(..), String, (.), ($), (+), (-), (*), (++), (&&), + fromIntegral, otherwise) +import qualified Data.List as L +import qualified Prelude as P +import Data.Text.Fusion.Internal + +singleton :: Char -> Stream Char +singleton c = Stream next False 1 -- HINT maybe too low + where next False = Yield c True + next True = Done +{-# INLINE singleton #-} + +streamList :: [a] -> Stream a +{-# INLINE [0] streamList #-} +streamList [] = empty +streamList s = Stream next s unknownLength + where next [] = Done + next (x:xs) = Yield x xs + unknownLength = 8 -- random HINT + +unstreamList :: Stream a -> [a] +{-# INLINE [0] unstreamList #-} +unstreamList (Stream next s0 _len) = unfold s0 + where unfold !s = case next s of + Done -> [] + Skip s' -> unfold s' + Yield x s' -> x : unfold s' + +{-# RULES "STREAM streamList/unstreamList fusion" forall s. streamList (unstreamList s) = s #-} + +-- ---------------------------------------------------------------------------- +-- * Basic stream functions + +-- | /O(n)/ Adds a character to the front of a Stream Char. +cons :: Char -> Stream Char -> Stream Char +cons w (Stream next0 s0 len) = Stream next (S2 :!: s0) (len+2) -- HINT maybe too high + where + {-# INLINE next #-} + next (S2 :!: s) = Yield w (S1 :!: s) + next (S1 :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (S1 :!: s') + Yield x s' -> Yield x (S1 :!: s') +{-# INLINE [0] cons #-} + +-- | /O(n)/ Adds a character to the end of a stream. +snoc :: Stream Char -> Char -> Stream Char +snoc (Stream next0 xs0 len) w = Stream next (J xs0) (len+2) -- HINT maybe too high + where + {-# INLINE next #-} + next (J xs) = case next0 xs of + Done -> Yield w N + Skip xs' -> Skip (J xs') + Yield x xs' -> Yield x (J xs') + next N = Done +{-# INLINE [0] snoc #-} + +-- | /O(n)/ Appends one Stream to the other. +append :: Stream Char -> Stream Char -> Stream Char +append (Stream next0 s01 len1) (Stream next1 s02 len2) = + Stream next (Left s01) (len1 + len2) + where + {-# INLINE next #-} + next (Left s1) = case next0 s1 of + Done -> Skip (Right s02) + Skip s1' -> Skip (Left s1') + Yield x s1' -> Yield x (Left s1') + next (Right s2) = case next1 s2 of + Done -> Done + Skip s2' -> Skip (Right s2') + Yield x s2' -> Yield x (Right s2') +{-# INLINE [0] append #-} + +-- | /O(1)/ Returns the first character of a Text, which must be non-empty. +-- Subject to array fusion. +head :: Stream Char -> Char +head (Stream next s0 _len) = loop_head s0 + where + loop_head !s = case next s of + Yield x _ -> x + Skip s' -> loop_head s' + Done -> streamError "head" "Empty stream" +{-# INLINE [0] head #-} + +-- | /O(1)/ Returns the first character and remainder of a 'Stream +-- Char', or 'Nothing' if empty. Subject to array fusion. +uncons :: Stream Char -> Maybe (Char, Stream Char) +uncons (Stream next s0 len) = loop_uncons s0 + where + loop_uncons !s = case next s of + Yield x s1 -> Just (x, Stream next s1 (len-1)) -- HINT maybe too high + Skip s' -> loop_uncons s' + Done -> Nothing +{-# INLINE [0] uncons #-} + +-- | /O(n)/ Returns the last character of a 'Stream Char', which must +-- be non-empty. +last :: Stream Char -> Char +last (Stream next s0 _len) = loop0_last s0 + where + loop0_last !s = case next s of + Done -> emptyError "last" + Skip s' -> loop0_last s' + Yield x s' -> loop_last x s' + loop_last !x !s = case next s of + Done -> x + Skip s' -> loop_last x s' + Yield x' s' -> loop_last x' s' +{-# INLINE[0] last #-} + +-- | /O(1)/ Returns all characters after the head of a Stream Char, which must +-- be non-empty. +tail :: Stream Char -> Stream Char +tail (Stream next0 s0 len) = Stream next (False :!: s0) (len-1) -- HINT maybe too high + where + {-# INLINE next #-} + next (False :!: s) = case next0 s of + Done -> emptyError "tail" + Skip s' -> Skip (False :!: s') + Yield _ s' -> Skip (True :!: s') + next (True :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (True :!: s') + Yield x s' -> Yield x (True :!: s') +{-# INLINE [0] tail #-} + + +-- | /O(1)/ Returns all but the last character of a Stream Char, which +-- must be non-empty. +init :: Stream Char -> Stream Char +init (Stream next0 s0 len) = Stream next (N :!: s0) (len-1) -- HINT maybe too high + where + {-# INLINE next #-} + next (N :!: s) = case next0 s of + Done -> emptyError "init" + Skip s' -> Skip (N :!: s') + Yield x s' -> Skip (J x :!: s') + next (J x :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (J x :!: s') + Yield x' s' -> Yield x (J x' :!: s') +{-# INLINE [0] init #-} + +-- | /O(1)/ Tests whether a Stream Char is empty or not. +null :: Stream Char -> Bool +null (Stream next s0 _len) = loop_null s0 + where + loop_null !s = case next s of + Done -> True + Yield _ _ -> False + Skip s' -> loop_null s' +{-# INLINE[0] null #-} + +-- | /O(n)/ Returns the number of characters in a text. +lengthI :: Integral a => Stream Char -> a +lengthI (Stream next s0 _len) = loop_length 0 s0 + where + loop_length !z s = case next s of + Done -> z + Skip s' -> loop_length z s' + Yield _ s' -> loop_length (z + 1) s' +{-# INLINE[0] lengthI #-} + +-- ---------------------------------------------------------------------------- +-- * Stream transformations + +-- | /O(n)/ 'map' @f @xs is the Stream Char obtained by applying @f@ to each element of +-- @xs@. +map :: (Char -> Char) -> Stream Char -> Stream Char +map f (Stream next0 s0 len) = Stream next s0 len -- HINT depends on f + where + {-# INLINE next #-} + next !s = case next0 s of + Done -> Done + Skip s' -> Skip s' + Yield x s' -> Yield (f x) s' +{-# INLINE [0] map #-} + +{-# + RULES "STREAM map/map fusion" forall f g s. + map f (map g s) = map (\x -> f (g x)) s + #-} + +-- | /O(n)/ Take a character and place it between each of the +-- characters of a 'Stream Char'. +intersperse :: Char -> Stream Char -> Stream Char +intersperse c (Stream next0 s0 len) = Stream next (s0 :!: N :!: S1) len -- HINT maybe too low + where + {-# INLINE next #-} + next (s :!: N :!: S1) = case next0 s of + Done -> Done + Skip s' -> Skip (s' :!: N :!: S1) + Yield x s' -> Skip (s' :!: J x :!: S1) + next (s :!: J x :!: S1) = Yield x (s :!: N :!: S2) + next (s :!: N :!: S2) = case next0 s of + Done -> Done + Skip s' -> Skip (s' :!: N :!: S2) + Yield x s' -> Yield c (s' :!: J x :!: S1) + next _ = internalError "intersperse" +{-# INLINE [0] intersperse #-} + +-- ---------------------------------------------------------------------------- +-- * Reducing Streams (folds) + +-- | foldl, applied to a binary operator, a starting value (typically the +-- left-identity of the operator), and a Stream, reduces the Stream using the +-- binary operator, from left to right. +foldl :: (b -> Char -> b) -> b -> Stream Char -> b +foldl f z0 (Stream next s0 _len) = loop_foldl z0 s0 + where + loop_foldl z !s = case next s of + Done -> z + Skip s' -> loop_foldl z s' + Yield x s' -> loop_foldl (f z x) s' +{-# INLINE [0] foldl #-} + +-- | A strict version of foldl. +foldl' :: (b -> Char -> b) -> b -> Stream Char -> b +foldl' f z0 (Stream next s0 _len) = loop_foldl' z0 s0 + where + loop_foldl' !z !s = case next s of + Done -> z + Skip s' -> loop_foldl' z s' + Yield x s' -> loop_foldl' (f z x) s' +{-# INLINE [0] foldl' #-} + +-- | foldl1 is a variant of foldl that has no starting value argument, +-- and thus must be applied to non-empty Streams. +foldl1 :: (Char -> Char -> Char) -> Stream Char -> Char +foldl1 f (Stream next s0 _len) = loop0_foldl1 s0 + where + loop0_foldl1 !s = case next s of + Skip s' -> loop0_foldl1 s' + Yield x s' -> loop_foldl1 x s' + Done -> emptyError "foldl1" + loop_foldl1 z !s = case next s of + Done -> z + Skip s' -> loop_foldl1 z s' + Yield x s' -> loop_foldl1 (f z x) s' +{-# INLINE [0] foldl1 #-} + +-- | A strict version of foldl1. +foldl1' :: (Char -> Char -> Char) -> Stream Char -> Char +foldl1' f (Stream next s0 _len) = loop0_foldl1' s0 + where + loop0_foldl1' !s = case next s of + Skip s' -> loop0_foldl1' s' + Yield x s' -> loop_foldl1' x s' + Done -> emptyError "foldl1" + loop_foldl1' !z !s = case next s of + Done -> z + Skip s' -> loop_foldl1' z s' + Yield x s' -> loop_foldl1' (f z x) s' +{-# INLINE [0] foldl1' #-} + +-- | 'foldr', applied to a binary operator, a starting value (typically the +-- right-identity of the operator), and a stream, reduces the stream using the +-- binary operator, from right to left. +foldr :: (Char -> b -> b) -> b -> Stream Char -> b +foldr f z (Stream next s0 _len) = loop_foldr s0 + where + loop_foldr !s = case next s of + Done -> z + Skip s' -> loop_foldr s' + Yield x s' -> f x (loop_foldr s') +{-# INLINE [0] foldr #-} + +-- | foldr1 is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty streams. +-- Subject to array fusion. +foldr1 :: (Char -> Char -> Char) -> Stream Char -> Char +foldr1 f (Stream next s0 _len) = loop0_foldr1 s0 + where + loop0_foldr1 !s = case next s of + Done -> emptyError "foldr1" + Skip s' -> loop0_foldr1 s' + Yield x s' -> loop_foldr1 x s' + + loop_foldr1 x !s = case next s of + Done -> x + Skip s' -> loop_foldr1 x s' + Yield x' s' -> f x (loop_foldr1 x' s') +{-# INLINE [0] foldr1 #-} + +intercalate :: Stream Char -> [Stream Char] -> Stream Char +intercalate s = concat . (L.intersperse s) +{-# INLINE [0] intercalate #-} + +-- ---------------------------------------------------------------------------- +-- ** Special folds + +-- | /O(n)/ Concatenate a list of streams. Subject to array fusion. +concat :: [Stream Char] -> Stream Char +concat = L.foldr append empty + +-- | Map a function over a stream that results in a stream and concatenate the +-- results. +concatMap :: (Char -> Stream Char) -> Stream Char -> Stream Char +concatMap f = foldr (append . f) empty + +-- | /O(n)/ any @p @xs determines if any character in the stream +-- @xs@ satisifes the predicate @p@. +any :: (Char -> Bool) -> Stream Char -> Bool +any p (Stream next0 s0 _len) = loop_any s0 + where + loop_any !s = case next0 s of + Done -> False + Skip s' -> loop_any s' + Yield x s' | p x -> True + | otherwise -> loop_any s' +{-# INLINE [0] any #-} + +-- | /O(n)/ all @p @xs determines if all characters in the 'Text' +-- @xs@ satisify the predicate @p@. +all :: (Char -> Bool) -> Stream Char -> Bool +all p (Stream next0 s0 _len) = loop_all s0 + where + loop_all !s = case next0 s of + Done -> True + Skip s' -> loop_all s' + Yield x s' | p x -> loop_all s' + | otherwise -> False +{-# INLINE [0] all #-} + +-- | /O(n)/ maximum returns the maximum value from a stream, which must be +-- non-empty. +maximum :: Stream Char -> Char +maximum (Stream next0 s0 _len) = loop0_maximum s0 + where + loop0_maximum !s = case next0 s of + Done -> emptyError "maximum" + Skip s' -> loop0_maximum s' + Yield x s' -> loop_maximum x s' + loop_maximum !z !s = case next0 s of + Done -> z + Skip s' -> loop_maximum z s' + Yield x s' + | x > z -> loop_maximum x s' + | otherwise -> loop_maximum z s' +{-# INLINE [0] maximum #-} + +-- | /O(n)/ minimum returns the minimum value from a 'Text', which must be +-- non-empty. +minimum :: Stream Char -> Char +minimum (Stream next0 s0 _len) = loop0_minimum s0 + where + loop0_minimum !s = case next0 s of + Done -> emptyError "minimum" + Skip s' -> loop0_minimum s' + Yield x s' -> loop_minimum x s' + loop_minimum !z !s = case next0 s of + Done -> z + Skip s' -> loop_minimum z s' + Yield x s' + | x < z -> loop_minimum x s' + | otherwise -> loop_minimum z s' +{-# INLINE [0] minimum #-} + +-- ----------------------------------------------------------------------------- +-- * Building streams + +scanl :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char +scanl f z0 (Stream next0 s0 len) = Stream next (S1 :!: z0 :!: s0) (len+1) -- HINT maybe too low + where + {-# INLINE next #-} + next (S1 :!: z :!: s) = Yield z (S2 :!: z :!: s) + next (S2 :!: z :!: s) = case next0 s of + Yield x s' -> let !x' = f z x + in Yield x' (S2 :!: x' :!: s') + Skip s' -> Skip (S2 :!: z :!: s') + Done -> Done +{-# INLINE [0] scanl #-} + +-- ----------------------------------------------------------------------------- +-- ** Accumulating maps + +-- | /O(n)/ Like a combination of 'map' and 'foldl'. Applies a +-- function to each element of a stream, passing an accumulating +-- parameter from left to right, and returns a final stream. +-- +-- /Note/: Unlike the version over lists, this function does not +-- return a final value for the accumulator, because the nature of +-- streams precludes it. +mapAccumL :: (a -> b -> (a,b)) -> a -> Stream b -> Stream b +mapAccumL f z0 (Stream next0 s0 len) = Stream next (s0 :!: z0) len -- HINT depends on f + where + {-# INLINE next #-} + next (s :!: z) = case next0 s of + Yield x s' -> let (z',y) = f z x + in Yield y (s' :!: z') + Skip s' -> Skip (s' :!: z) + Done -> Done +{-# INLINE [0] mapAccumL #-} + +-- ----------------------------------------------------------------------------- +-- ** Generating and unfolding streams + +replicate :: Int -> Char -> Stream Char +replicate n c + | n < 0 = empty + | otherwise = Stream next 0 n -- HINT maybe too low + where + {-# INLINE next #-} + next i | i >= n = Done + | otherwise = Yield c (i + 1) +{-# INLINE [0] replicate #-} + +-- | /O(n)/, where @n@ is the length of the result. The unfoldr function +-- is analogous to the List 'unfoldr'. unfoldr builds a stream +-- from a seed value. The function takes the element and returns +-- Nothing if it is done producing the stream or returns Just +-- (a,b), in which case, a is the next Char in the string, and b is +-- the seed value for further production. +unfoldr :: (a -> Maybe (Char,a)) -> a -> Stream Char +unfoldr f s0 = Stream next s0 1 -- HINT maybe too low + where + {-# INLINE next #-} + next !s = case f s of + Nothing -> Done + Just (w, s') -> Yield w s' +{-# INLINE [0] unfoldr #-} + +-- | /O(n)/ Like 'unfoldr', 'unfoldrNI' builds a stream from a seed +-- value. However, the length of the result is limited by the +-- first argument to 'unfoldrNI'. This function is more efficient than +-- 'unfoldr' when the length of the result is known. +unfoldrNI :: Integral a => a -> (b -> Maybe (Char,b)) -> b -> Stream Char +unfoldrNI n f s0 | n < 0 = empty + | otherwise = Stream next (0 :!: s0) (fromIntegral (n*2)) -- HINT maybe too high + where + {-# INLINE next #-} + next (z :!: s) = case f s of + Nothing -> Done + Just (w, s') | z >= n -> Done + | otherwise -> Yield w ((z + 1) :!: s') +{-# INLINE unfoldrNI #-} + +------------------------------------------------------------------------------- +-- * Substreams + +-- | /O(n)/ take n, applied to a stream, returns the prefix of the +-- stream of length @n@, or the stream itself if @n@ is greater than the +-- length of the stream. +take :: Integral a => a -> Stream Char -> Stream Char +take n0 (Stream next0 s0 len) = Stream next (n0 :!: s0) (min 0 (len - fromIntegral n0)) -- HINT maybe too high + where + {-# INLINE next #-} + next (n :!: s) | n <= 0 = Done + | otherwise = case next0 s of + Done -> Done + Skip s' -> Skip (n :!: s') + Yield x s' -> Yield x ((n-1) :!: s') +{-# 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. +drop :: Integral a => a -> Stream Char -> Stream Char +drop n0 (Stream next0 s0 len) = + Stream next (J (max 0 n0) :!: s0) (len - fromIntegral n0) -- HINT maybe too high + where + {-# INLINE next #-} + next (J n :!: s) + | n == 0 = Skip (N :!: s) + | otherwise = case next0 s of + Done -> Done + Skip s' -> Skip (J n :!: s') + Yield _ s' -> Skip (J (n-1) :!: s') + next (N :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (N :!: s') + Yield x s' -> Yield x (N :!: s') +{-# INLINE [0] drop #-} + +-- | takeWhile, applied to a predicate @p@ and a stream, returns the +-- longest prefix (possibly empty) of elements that satisfy p. +takeWhile :: (Char -> Bool) -> Stream Char -> Stream Char +takeWhile p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high + where + {-# INLINE next #-} + next !s = case next0 s of + Done -> Done + Skip s' -> Skip s' + Yield x s' | p x -> Yield x s' + | otherwise -> Done +{-# INLINE [0] takeWhile #-} + +-- | dropWhile @p @xs returns the suffix remaining after takeWhile @p @xs. +dropWhile :: (Char -> Bool) -> Stream Char -> Stream Char +dropWhile p (Stream next0 s0 len) = Stream next (S1 :!: s0) len -- HINT maybe too high + where + {-# INLINE next #-} + next (S1 :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (S1 :!: s') + Yield x s' | p x -> Skip (S1 :!: s') + | otherwise -> Yield x (S2 :!: s') + next (S2 :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (S2 :!: s') + Yield x s' -> Yield x (S2 :!: s') +{-# INLINE [0] dropWhile #-} + +-- | /O(n)/ The 'isPrefixOf' function takes two 'Stream's and returns +-- 'True' iff the first is a prefix of the second. +isPrefixOf :: (Eq a) => Stream a -> Stream a -> Bool +isPrefixOf (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2) + where + loop Done _ = True + loop _ Done = False + loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2') + loop (Skip s1') x2 = loop (next1 s1') x2 + loop x1 (Skip s2') = loop x1 (next2 s2') + loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 && + loop (next1 s1') (next2 s2') +{-# INLINE [0] isPrefixOf #-} +{-# SPECIALISE isPrefixOf :: Stream Char -> Stream Char -> Bool #-} + +-- ---------------------------------------------------------------------------- +-- * Searching + +------------------------------------------------------------------------------- +-- ** Searching by equality + +-- | /O(n)/ elem is the stream membership predicate. +elem :: Char -> Stream Char -> Bool +elem w (Stream next s0 _len) = loop_elem s0 + where + loop_elem !s = case next s of + Done -> False + Skip s' -> loop_elem s' + Yield x s' | x == w -> True + | otherwise -> loop_elem s' +{-# INLINE [0] elem #-} + +------------------------------------------------------------------------------- +-- ** Searching with a predicate + +-- | /O(n)/ The 'find' function takes a predicate and a stream, +-- and returns the first element in matching the predicate, or 'Nothing' +-- if there is no such element. + +find :: (Char -> Bool) -> Stream Char -> Maybe Char +find p (Stream next s0 _len) = loop_find s0 + where + loop_find !s = case next s of + Done -> Nothing + Skip s' -> loop_find s' + Yield x s' | p x -> Just x + | otherwise -> loop_find s' +{-# INLINE [0] find #-} + +-- | /O(n)/ Stream index (subscript) operator, starting from 0. +indexI :: Integral a => Stream Char -> a -> Char +indexI (Stream next s0 _len) n0 + | n0 < 0 = streamError "index" "Negative index" + | otherwise = loop_index n0 s0 + where + loop_index !n !s = case next s of + Done -> streamError "index" "Index too large" + Skip s' -> loop_index n s' + Yield x s' | n == 0 -> x + | otherwise -> loop_index (n-1) s' +{-# INLINE [0] indexI #-} + +-- | /O(n)/ 'filter', applied to a predicate and a stream, +-- returns a stream containing those characters that satisfy the +-- predicate. +filter :: (Char -> Bool) -> Stream Char -> Stream Char +filter p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high + where + {-# INLINE next #-} + next !s = case next0 s of + Done -> Done + Skip s' -> Skip s' + Yield x s' | p x -> Yield x s' + | otherwise -> Skip s' +{-# INLINE [0] filter #-} + +{-# RULES + "Stream filter/filter fusion" forall p q s. + filter p (filter q s) = filter (\x -> q x && p x) s + #-} + +-- | The 'findIndexI' function takes a predicate and a stream and +-- returns the index of the first element in the stream satisfying the +-- predicate. +findIndexI :: Integral a => (Char -> Bool) -> Stream Char -> Maybe a +findIndexI p s = case findIndicesI p s of + (i:_) -> Just i + _ -> Nothing +{-# INLINE [0] findIndexI #-} + +-- | The 'findIndicesI' function takes a predicate and a stream and +-- returns all indices of the elements in the stream satisfying the +-- predicate. +findIndicesI :: Integral a => (Char -> Bool) -> Stream Char -> [a] +findIndicesI p (Stream next s0 _len) = loop_findIndex 0 s0 + where + loop_findIndex !i !s = case next s of + Done -> [] + Skip s' -> loop_findIndex i s' -- hmm. not caught by QC + Yield x s' | p x -> i : loop_findIndex (i+1) s' + | otherwise -> loop_findIndex (i+1) s' +{-# INLINE [0] findIndicesI #-} + +------------------------------------------------------------------------------- +-- * Zipping + +-- | zipWith generalises 'zip' by zipping with the function given as +-- the first argument, instead of a tupling function. +zipWith :: (a -> a -> b) -> Stream a -> Stream a -> Stream b +zipWith f (Stream next0 sa0 len1) (Stream next1 sb0 len2) = Stream next (sa0 :!: sb0 :!: N) (min len1 len2) + where + {-# INLINE next #-} + next (sa :!: sb :!: N) = case next0 sa of + Done -> Done + Skip sa' -> Skip (sa' :!: sb :!: N) + Yield a sa' -> Skip (sa' :!: sb :!: J a) + + next (sa' :!: sb :!: J a) = case next1 sb of + Done -> Done + Skip sb' -> Skip (sa' :!: sb' :!: J a) + Yield b sb' -> Yield (f a b) (sa' :!: sb' :!: N) +{-# INLINE [0] zipWith #-} + +-- | /O(n)/ The 'elemIndexI' function returns the index of the first +-- element in the given stream which is equal to the query +-- element, or 'Nothing' if there is no such element. +elemIndexI :: Integral a => Char -> Stream Char -> Maybe a +elemIndexI a s = case elemIndicesI a s of + (i:_) -> Just i + _ -> Nothing +{-# INLINE [0] elemIndexI #-} + +-- | /O(n)/ The 'elemIndicesI' function returns the index of every +-- element in the given stream which is equal to the query element. +elemIndicesI :: Integral a => Char -> Stream Char -> [a] +elemIndicesI a (Stream next s0 _len) = loop 0 s0 + where + loop !i !s = case next s of + Done -> [] + Skip s' -> loop i s' + Yield x s' | a == x -> i : loop (i+1) s' + | otherwise -> loop (i+1) s' +{-# INLINE [0] elemIndicesI #-} + +-- | /O(n)/ The 'count' function returns the number of times the query +-- element appears in the given stream. +countI :: Integral a => Char -> Stream Char -> a +countI a (Stream next s0 _len) = loop 0 s0 + where + loop !i !s = case next s of + Done -> i + Skip s' -> loop i s' + Yield x s' | a == x -> loop (i+1) s' + | otherwise -> loop i s' +{-# INLINE [0] countI #-} + +streamError :: String -> String -> a +streamError func msg = P.error $ "Data.Text.Fusion.Common." ++ func ++ ": " ++ msg + +emptyError :: String -> a +emptyError func = internalError func "Empty input" + +internalError :: String -> a +internalError func = streamError func "Internal error" diff --git a/Data/Text/Fusion/Internal.hs b/Data/Text/Fusion/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Fusion/Internal.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE BangPatterns, ExistentialQuantification #-} +-- | +-- Module : Data.Text.Fusion.Internal +-- Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com, rtharper@aftereternity.co.uk, +-- duncan@haskell.org +-- Stability : experimental +-- Portability : GHC +-- +-- Core stream fusion functionality for text. + +module Data.Text.Fusion.Internal + ( + M(..) + , M8 + , PairS(..) + , S(..) + , Step(..) + , Stream(..) + , Switch(..) + , empty + ) where + +import Data.Word (Word8) + +-- | Specialised, strict Maybe-like type. +data M a = N + | J {-# UNPACK #-} !a + deriving (Eq, Ord, Show) + +type M8 = M Word8 + +-- Restreaming state. +data S s = S {-# UNPACK #-} !s + {-# UNPACK #-} !M8 {-# UNPACK #-} !M8 {-# UNPACK #-} !M8 + deriving (Eq, Ord, Show) + +infixl 2 :!: +data PairS a b = !a :!: !b + deriving (Eq, Ord, Read, Show) + +-- | Allow a function over a stream to switch between two states. +data Switch = S1 | S2 + deriving (Eq, Ord, Show) + +data Step s a = Done + | Skip !s + | Yield !a !s + +instance Show a => Show (Step s a) + where show Done = "Done" + show (Skip _) = "Skip" + show (Yield x _) = "Yield " ++ show x + +instance (Eq a) => Eq (Stream a) where + (==) = eq + +instance (Ord a) => Ord (Stream a) where + compare = cmp + +-- The length hint in a Stream has two roles. If its value is zero, +-- we trust it, and treat the stream as empty. Otherwise, we treat it +-- as a hint: it should usually be accurate, so we use it when +-- unstreaming to decide what size array to allocate. However, the +-- unstreaming functions must be able to cope with the hint being too +-- small or too large. +-- +-- The size hint tries to track the UTF-16 code points in a stream, +-- but often counts the number of characters instead. It can easily +-- undercount if, for instance, a transformed stream contains astral +-- plane characters (those above 0x10000). + +data Stream a = + forall s. Stream + (s -> Step s a) -- stepper function + !s -- current state + {-# UNPACK #-}!Int -- length hint + +-- | /O(n)/ Determines if two streams are equal. +eq :: (Eq a) => Stream a -> Stream a -> Bool +eq (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2) + where + loop Done Done = True + loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2') + loop (Skip s1') x2 = loop (next1 s1') x2 + loop x1 (Skip s2') = loop x1 (next2 s2') + loop Done _ = False + loop _ Done = False + loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 && + loop (next1 s1') (next2 s2') +{-# INLINE [0] eq #-} +{-# SPECIALISE eq :: Stream Char -> Stream Char -> Bool #-} + +cmp :: (Ord a) => Stream a -> Stream a -> Ordering +cmp (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2) + where + loop Done Done = EQ + loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2') + loop (Skip s1') x2 = loop (next1 s1') x2 + loop x1 (Skip s2') = loop x1 (next2 s2') + loop Done _ = LT + loop _ Done = GT + loop (Yield x1 s1') (Yield x2 s2') = + case compare x1 x2 of + EQ -> loop (next1 s1') (next2 s2') + other -> other +{-# INLINE [0] cmp #-} +{-# SPECIALISE cmp :: Stream Char -> Stream Char -> Ordering #-} + +-- | The empty stream. +empty :: Stream a +empty = Stream next () 0 + where next _ = Done +{-# INLINE [0] empty #-} diff --git a/Data/Text/Internal.hs b/Data/Text/Internal.hs --- a/Data/Text/Internal.hs +++ b/Data/Text/Internal.hs @@ -1,13 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-} -- | --- Module : Data.Text +-- Module : Data.Text.Internal -- Copyright : (c) Tom Harper 2008-2009, -- (c) Bryan O'Sullivan 2009, -- (c) Duncan Coutts 2009 -- -- License : BSD-style --- Maintainer : rtharper@aftereternity.co.uk, bos@serpentine.com, +-- Maintainer : bos@serpentine.com, rtharper@aftereternity.co.uk, -- duncan@haskell.org -- Stability : experimental -- Portability : GHC @@ -21,6 +21,7 @@ Text(..) -- * Construction , text + , textP -- * Code that must be here for accessibility , empty -- * Debugging @@ -55,6 +56,13 @@ empty :: Text empty = Text A.empty 0 0 {-# INLINE [1] empty #-} + +-- | 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 arr off len | len == 0 = empty + | otherwise = text arr off len +{-# INLINE textP #-} -- | A useful 'show'-like function for debugging purposes. showText :: Text -> String diff --git a/Data/Text/Lazy.hs b/Data/Text/Lazy.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Lazy.hs @@ -0,0 +1,872 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Text.Lazy +-- Copyright : (c) Bryan O'Sullivan 2009 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com, rtharper@aftereternity.co.uk, +-- duncan@haskell.org +-- Stability : experimental +-- Portability : GHC +-- +-- A time and space-efficient implementation of Unicode text using +-- lists of packed arrays. This representation is suitable for high +-- performance use and for streaming large quantities of data. It +-- provides a means to manipulate a large body of text without +-- requiring that the entire content be resident in memory. +-- +-- Some operations, such as 'concat', 'append', 'reverse' and 'cons', +-- have better complexity than their "Data.Text" equivalents, due to +-- optimisations resulting from the list spine structure. And for +-- other operations lazy 'Text's are usually within a few percent of +-- strict ones, but with better heap usage. For data larger than +-- available memory, or if you have tight memory constraints, this +-- module will be the only option. +-- +-- This module is intended to be imported @qualified@, to avoid name +-- clashes with "Prelude" functions. eg. +-- +-- > import qualified Data.Text.Lazy as B + +module Data.Text.Lazy + ( + Text + -- * Creation and elimination + , pack + , unpack + , singleton + , empty + , fromChunks + , toChunks + + -- * Basic interface + , cons + , snoc + , append + , uncons + , head + , last + , tail + , init + , null + , length + + -- * Transformations + , map + , intercalate + , intersperse + , transpose + , reverse + + -- * Folds + , foldl + , foldl' + , foldl1 + , foldl1' + , foldr + , foldr1 + + -- ** Special folds + , concat + , concatMap + , any + , all + , maximum + , minimum + + -- * Construction + + -- ** Scans + , scanl + , scanl1 + , scanr + , scanr1 + + -- ** Accumulating maps + , mapAccumL + , mapAccumR + + -- ** Generation and unfolding + , replicate + , unfoldr + , unfoldrN + + -- * Substrings + + -- ** Breaking strings + , take + , drop + , takeWhile + , dropWhile + , splitAt + , span + , break + , group + , groupBy + , inits + , tails + + -- ** Breaking into many substrings + , split + , splitWith + -- , breakSubstring + + -- ** Breaking into lines and words + , lines + , words + , unlines + , unwords + + -- * Predicates + , isPrefixOf + , isSuffixOf + , isInfixOf + + -- * Searching + , elem + , filter + , find + , partition + + -- , findSubstring + + -- * Indexing + , index + , findIndex + , findIndices + , elemIndex + , elemIndices + , count + + -- * Zipping and unzipping + , zip + , zipWith + + -- -* Ordered text + -- , sort + ) where + +import Prelude (Char, Bool(..), Int, Maybe(..), String, + Eq(..), Ord(..), Read(..), Show(..), + (&&), (+), (-), (.), ($), (++), + flip, fromIntegral, not, otherwise) +import qualified Prelude as P +import Data.Int (Int64) +import qualified Data.List as L +import Data.Char (isSpace) +import Data.String (IsString(..)) +import qualified Data.Text as T +import qualified Data.Text.Fusion.Common as S +import qualified Data.Text.Unsafe as T +import qualified Data.Text.Lazy.Fusion as S +import Data.Text.Lazy.Fusion (stream, unstream) +import Data.Text.Lazy.Internal + +instance Eq Text where + t1 == t2 = stream t1 == stream t2 + {-# INLINE (==) #-} + +instance Ord Text where + compare t1 t2 = compare (stream t1) (stream t2) + {-# INLINE compare #-} + +instance Show Text where + showsPrec p ps r = showsPrec p (unpack ps) r + +instance Read Text where + readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str] + +instance IsString Text where + fromString = pack + +-- | /O(n)/ Convert a 'String' into a 'Text'. +-- +-- This function is subject to array fusion. +pack :: String -> Text +pack s = unstream (S.streamList s) +{-# INLINE [1] pack #-} + +-- | /O(n)/ Convert a 'Text' into a 'String'. +-- Subject to array fusion. +unpack :: Text -> String +unpack t = S.unstreamList (stream t) +{-# INLINE [1] unpack #-} + +singleton :: Char -> Text +singleton c = Chunk (T.singleton c) Empty +{-# INLINE [1] singleton #-} + +{-# RULES +"LAZY TEXT singleton -> fused" [~1] forall c. + singleton c = unstream (S.singleton c) +"LAZY TEXT singleton -> unfused" [1] forall c. + unstream (S.singleton c) = singleton c + #-} + +-- | /O(c)/ Convert a list of strict 'T.Text's into a lazy 'Text'. +fromChunks :: [T.Text] -> Text +fromChunks cs = L.foldr chunk Empty cs + +-- | /O(n)/ Convert a lazy 'Text' into a list of strict 'T.Text's. +toChunks :: Text -> [T.Text] +toChunks cs = foldrChunks (:) [] cs + +cons :: Char -> Text -> Text +cons c t = Chunk (T.singleton c) t +{-# INLINE [1] cons #-} + +{-# RULES +"LAZY TEXT cons -> fused" [~1] forall c t. + cons c t = unstream (S.cons c (stream t)) +"LAZY TEXT cons -> unfused" [1] forall c t. + unstream (S.cons c (stream t)) = cons c t + #-} + +snoc :: Text -> Char -> Text +snoc t c = foldrChunks Chunk (singleton c) t +{-# INLINE [1] snoc #-} + +{-# RULES +"LAZY TEXT snoc -> fused" [~1] forall t c. + snoc t c = unstream (S.snoc (stream t) c) +"LAZY TEXT snoc -> unfused" [1] forall t c. + unstream (S.snoc (stream t) c) = snoc t c + #-} + +-- | /O(n\/c)/ Appends one 'Text' to another. Subject to array +-- fusion. +append :: Text -> Text -> Text +append xs ys = foldrChunks Chunk ys xs +{-# INLINE [1] append #-} + +{-# RULES +"LAZY TEXT append -> fused" [~1] forall t1 t2. + append t1 t2 = unstream (S.append (stream t1) (stream t2)) +"LAZY TEXT append -> unfused" [1] forall t1 t2. + unstream (S.append (stream t1) (stream t2)) = append t1 t2 + #-} + +-- | /O(1)/ Returns the first character and rest of a 'Text', or +-- 'Nothing' if empty. Subject to array fusion. +uncons :: Text -> Maybe (Char, Text) +uncons Empty = Nothing +uncons (Chunk t ts) = + Just (T.unsafeHead t, + if T.length t == 1 then ts else Chunk (T.unsafeTail t) ts) +{-# INLINE uncons #-} + +-- | /O(1)/ Returns the first character of a 'Text', which must be +-- non-empty. Subject to array fusion. +head :: Text -> Char +head t = S.head (stream t) +{-# INLINE head #-} + +-- | /O(1)/ Returns all characters after the head of a 'Text', which +-- must be non-empty. Subject to array fusion. +tail :: Text -> Text +tail (Chunk t ts) = chunk (T.tail t) ts +tail Empty = emptyError "tail" +{-# INLINE [1] tail #-} + +{-# RULES +"LAZY TEXT tail -> fused" [~1] forall t. + tail t = unstream (S.tail (stream t)) +"LAZY TEXT tail -> unfused" [1] forall t. + unstream (S.tail (stream t)) = tail t + #-} + +-- | /O(1)/ Returns all but the last character of a 'Text', which must +-- be non-empty. Subject to array fusion. +init :: Text -> Text +init (Chunk t0 ts0) = go t0 ts0 + where go t (Chunk t' ts) = Chunk t (go t' ts) + go t Empty = chunk (T.init t) Empty +init Empty = emptyError "init" +{-# INLINE [1] init #-} + +{-# RULES +"LAZY TEXT init -> fused" [~1] forall t. + init t = unstream (S.init (stream t)) +"LAZY TEXT init -> unfused" [1] forall t. + unstream (S.init (stream t)) = init t + #-} + +-- | /O(1)/ Tests whether a 'Text' is empty or not. Subject to array +-- fusion. +null :: Text -> Bool +null Empty = True +null _ = False +{-# INLINE [1] null #-} + +{-# RULES +"LAZY TEXT null -> fused" [~1] forall t. + null t = S.null (stream t) +"LAZY TEXT null -> unfused" [1] forall t. + S.null (stream t) = null t + #-} + +-- | /O(1)/ Returns the last character of a 'Text', which must be +-- non-empty. Subject to array fusion. +last :: Text -> Char +last Empty = emptyError "last" +last (Chunk t ts) = go t ts + where go _ (Chunk t' ts') = go t' ts' + go t' Empty = T.last t' +{-# INLINE [1] last #-} + +{-# RULES +"LAZY TEXT last -> fused" [~1] forall t. + last t = S.last (stream t) +"LAZY TEXT last -> unfused" [1] forall t. + S.last (stream t) = last t + #-} + +length :: Text -> Int64 +length = foldlChunks go 0 + where go l t = l + fromIntegral (T.length t) +{-# INLINE [1] length #-} + +{-# RULES +"LAZY TEXT length -> fused" [~1] forall t. + length t = S.length (stream t) +"LAZY TEXT length -> unfused" [1] forall t. + S.length (stream t) = length t + #-} + +-- | /O(n)/ 'map' @f @xs is the 'Text' obtained by applying @f@ to +-- each element of @xs@. Subject to array fusion. +map :: (Char -> Char) -> Text -> Text +map f t = unstream (S.map f (stream t)) +{-# INLINE [1] map #-} + +-- | /O(n)/ The 'intercalate' function takes a 'Text' and a list of +-- 'Text's and concatenates the list after interspersing the first +-- argument between each element of the list. +intercalate :: Text -> [Text] -> Text +intercalate t ts = unstream (S.intercalate (stream t) (L.map stream ts)) +{-# INLINE intercalate #-} + +-- | /O(n)/ The 'intersperse' function takes a character and places it +-- between the characters of a 'Text'. Subject to array fusion. +intersperse :: Char -> Text -> Text +intersperse c t = unstream (S.intersperse c (stream t)) +{-# INLINE intersperse #-} + +-- | /O(n)/ The 'transpose' function transposes the rows and columns +-- of its 'Text' argument. Note that this function uses 'pack', +-- 'unpack', and the list version of transpose, and is thus not very +-- efficient. +transpose :: [Text] -> [Text] +transpose ts = L.map (\ss -> Chunk (T.pack ss) Empty) + (L.transpose (L.map unpack ts)) +-- TODO: make this fast + +-- | /O(n)/ 'reverse' @t@ returns the elements of @t@ in reverse order. +reverse :: Text -> Text +reverse = rev Empty + where rev a Empty = a + rev a (Chunk t ts) = rev (Chunk (T.reverse t) a) ts + +-- | /O(n)/ 'foldl', applied to a binary operator, a starting value +-- (typically the left-identity of the operator), and a 'Text', +-- reduces the 'Text' using the binary operator, from left to right. +-- Subject to array fusion. +foldl :: (b -> Char -> b) -> b -> Text -> b +foldl f z t = S.foldl f z (stream t) +{-# INLINE foldl #-} + +-- | /O(n)/ A strict version of 'foldl'. +-- Subject to array fusion. +foldl' :: (b -> Char -> b) -> b -> Text -> b +foldl' f z t = S.foldl' f z (stream t) +{-# INLINE foldl' #-} + +-- | /O(n)/ A variant of 'foldl' that has no starting value argument, +-- and thus must be applied to a non-empty 'Text'. Subject to array +-- fusion. +foldl1 :: (Char -> Char -> Char) -> Text -> Char +foldl1 f t = S.foldl1 f (stream t) +{-# INLINE foldl1 #-} + +-- | /O(n)/ A strict version of 'foldl1'. +-- Subject to array fusion. +foldl1' :: (Char -> Char -> Char) -> Text -> Char +foldl1' f t = S.foldl1' f (stream t) +{-# INLINE foldl1' #-} + +-- | /O(n)/ 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a 'Text', +-- reduces the 'Text' using the binary operator, from right to left. +-- Subject to array fusion. +foldr :: (Char -> b -> b) -> b -> Text -> b +foldr f z t = S.foldr f z (stream t) +{-# INLINE foldr #-} + +-- | /O(n)/ A variant of 'foldr' that has no starting value argument, and +-- thust must be applied to a non-empty 'Text'. Subject to array +-- fusion. +foldr1 :: (Char -> Char -> Char) -> Text -> Char +foldr1 f t = S.foldr1 f (stream t) +{-# INLINE foldr1 #-} + +-- | /O(n)/ Concatenate a list of 'Text's. Subject to array fusion. +concat :: [Text] -> Text +concat ts = unstream (S.concat (L.map stream ts)) +{-# INLINE concat #-} + +-- | /O(n)/ Map a function over a 'Text' that results in a 'Text', and +-- concatenate the results. This function is subject to array fusion. +-- +-- Note: if in 'concatMap' @f@ @t@, @f@ is defined in terms of fusible +-- functions, it will also be fusible. +concatMap :: (Char -> Text) -> Text -> Text +concatMap f t = unstream (S.concatMap (stream . f) (stream t)) +{-# INLINE concatMap #-} + +-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the +-- 'Text' @t@ satisifes the predicate @p@. Subject to array fusion. +any :: (Char -> Bool) -> Text -> Bool +any p t = S.any p (stream t) +{-# INLINE any #-} + +-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the +-- 'Text' @t@ satisify the predicate @p@. Subject to array fusion. +all :: (Char -> Bool) -> Text -> Bool +all p t = S.all p (stream t) +{-# INLINE all #-} + +-- | /O(n)/ 'maximum' returns the maximum value from a 'Text', which +-- must be non-empty. Subject to array fusion. +maximum :: Text -> Char +maximum t = S.maximum (stream t) +{-# INLINE maximum #-} + +-- | /O(n)/ 'minimum' returns the minimum value from a 'Text', which +-- must be non-empty. Subject to array fusion. +minimum :: Text -> Char +minimum t = S.minimum (stream t) +{-# INLINE minimum #-} + +-- | /O(n)/ 'scanl' is similar to 'foldl', but returns a list of +-- successive reduced values from the left. This function is subject +-- to array fusion. +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Note that +-- +-- > last (scanl f z xs) == foldl f z xs. +scanl :: (Char -> Char -> Char) -> Char -> Text -> Text +scanl f z t = unstream (S.scanl f z (stream t)) +{-# INLINE scanl #-} + +-- | /O(n)/ 'scanl1' is a variant of 'scanl' that has no starting +-- value argument. This function is subject to array fusion. +-- +-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] +scanl1 :: (Char -> Char -> Char) -> Text -> Text +scanl1 f t0 = case uncons t0 of + Nothing -> empty + Just (t,ts) -> scanl f t ts +{-# INLINE scanl1 #-} + +-- | /O(n)/ 'scanr' is the right-to-left dual of 'scanl'. +-- +-- > scanr f v == reverse . scanl (flip f) v . reverse +scanr :: (Char -> Char -> Char) -> Char -> Text -> Text +scanr f v = reverse . scanl (flip f) v . reverse + +-- | /O(n)/ 'scanr1' is a variant of 'scanr' that has no starting +-- value argument. +scanr1 :: (Char -> Char -> Char) -> Text -> Text +scanr1 f t | null t = empty + | otherwise = scanr f (last t) (init t) + +-- | /O(n)/ Like a combination of 'map' and 'foldl'. Applies a +-- function to each element of a 'Text', passing an accumulating +-- parameter from left to right, and returns a final 'Text'. +mapAccumL :: (a -> Char -> (a,Char)) -> a -> Text -> (a, Text) +mapAccumL f s t = case uncons t of + Nothing -> (s, empty) + Just (x, xs) -> (s'', cons y ys) + where (s', y ) = f s x + (s'',ys) = mapAccumL f s' xs + +-- | The 'mapAccumR' function behaves like a combination of 'map' and +-- 'foldr'; it applies a function to each element of a 'Text', passing +-- an accumulating parameter from right to left, and returning a final +-- value of this accumulator together with the new 'Text'. +mapAccumR :: (a -> Char -> (a,Char)) -> a -> Text -> (a, Text) +mapAccumR f s t = case uncons t of + Nothing -> (s, empty) + Just (x, xs) -> (s'', cons y ys) + where (s'',y ) = f s' x + (s', ys) = mapAccumR f s xs + +-- | /O(n)/ 'replicate' @n@ @c@ is a 'Text' of length @n@ with @c@ the +-- value of every element. +replicate :: Int -> Char -> Text +replicate n c = unstream (S.replicate n c) +{-# INLINE replicate #-} + +-- | /O(n)/, where @n@ is the length of the result. The 'unfoldr' +-- function is analogous to the List 'L.unfoldr'. 'unfoldr' builds a +-- 'Text' from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the 'Text', otherwise +-- 'Just' @(a,b)@. In this case, @a@ is the next 'Char' in the +-- string, and @b@ is the seed value for further production. +unfoldr :: (a -> Maybe (Char,a)) -> a -> Text +unfoldr f s = unstream (S.unfoldr f s) +{-# INLINE unfoldr #-} + +-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'Text' from a seed +-- value. However, the length of the result should be limited by the +-- first argument to 'unfoldrN'. This function is more efficient than +-- 'unfoldr' when the maximum length of the result is known and +-- correct, otherwise its performance is similar to 'unfoldr'. +unfoldrN :: Int64 -> (a -> Maybe (Char,a)) -> a -> Text +unfoldrN n f s = unstream (S.unfoldrN n f s) +{-# INLINE unfoldrN #-} + +-- | /O(n)/ 'take' @n@, applied to a 'Text', returns the prefix of the +-- 'Text' of length @n@, or the 'Text' itself if @n@ is greater than +-- the length of the Text. Subject to fusion. +take :: Int64 -> Text -> Text +take i _ | i <= 0 = Empty +take i t0 = take' i t0 + where take' 0 _ = Empty + take' _ Empty = Empty + take' n (Chunk t ts) + | n < len = Chunk (T.take (fromIntegral n) t) Empty + | otherwise = Chunk t (take' (n - len) ts) + where len = fromIntegral (T.length t) +{-# INLINE [1] take #-} + +{-# RULES +"LAZY TEXT take -> fused" [~1] forall n t. + take n t = unstream (S.take n (stream t)) +"LAZY TEXT take -> unfused" [1] forall n t. + unstream (S.take n (stream t)) = take n t + #-} + +-- | /O(n)/ '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. +drop :: Int -> Text -> Text +drop i t0 + | i <= 0 = t0 + | otherwise = drop' i t0 + where drop' 0 ts = ts + drop' _ Empty = Empty + drop' n (Chunk t ts) + | n < len = Chunk (T.drop (fromIntegral n) t) ts + | otherwise = drop' (n - len) ts + where len = fromIntegral (T.length t) +{-# INLINE [1] drop #-} + +{-# RULES +"LAZY TEXT drop -> fused" [~1] forall n t. + drop n t = unstream (S.drop n (stream t)) +"LAZY TEXT drop -> unfused" [1] forall n t. + unstream (S.drop n (stream t)) = drop n t + #-} + +-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'Text', returns +-- the longest prefix (possibly empty) of elements that satisfy @p@. +-- This function is subject to array fusion. +takeWhile :: (Char -> Bool) -> Text -> Text +takeWhile p t0 = takeWhile' t0 + where takeWhile' Empty = Empty + takeWhile' (Chunk t ts) = + case T.findIndex (not . p) t of + Just n | n > 0 -> Chunk (T.take n t) Empty + | otherwise -> Empty + Nothing -> Chunk t (takeWhile' ts) +{-# INLINE [1] takeWhile #-} + +{-# RULES +"LAZY TEXT takeWhile -> fused" [~1] forall p t. + takeWhile p t = unstream (S.takeWhile p (stream t)) +"LAZY TEXT takeWhile -> unfused" [1] forall p t. + unstream (S.takeWhile p (stream t)) = takeWhile p t + #-} + +-- | /O(n)/ 'dropWhile' @p@ @xs@ returns the suffix remaining after +-- 'takeWhile' @p@ @xs@. This function is subject to array fusion. +dropWhile :: (Char -> Bool) -> Text -> Text +dropWhile p t0 = dropWhile' t0 + where dropWhile' Empty = Empty + dropWhile' (Chunk t ts) = + case T.findIndex (not . p) t of + Just n -> Chunk (T.drop n t) ts + Nothing -> dropWhile' ts +{-# INLINE [1] dropWhile #-} + +{-# RULES +"LAZY TEXT dropWhile -> fused" [~1] forall p t. + dropWhile p t = unstream (S.dropWhile p (stream t)) +"LAZY TEXT dropWhile -> unfused" [1] forall p t. + unstream (S.dropWhile p (stream t)) = dropWhile p t + #-} + +-- | /O(n)/ 'splitAt' @n t@ returns a pair whose first element is a +-- prefix of @t@ of length @n@, and whose second is the remainder of +-- the string. It is equivalent to @('take' n t, 'drop' n t)@. +splitAt :: Int64 -> Text -> (Text, Text) +splitAt = loop + where loop _ Empty = (empty, empty) + loop n t | n <= 0 = (empty, t) + loop n (Chunk t ts) + | n < len = let (t',t'') = T.splitAt (fromIntegral n) t + in (Chunk t' Empty, Chunk t'' ts) + | otherwise = let (ts',ts'') = loop (n - len) ts + in (Chunk t ts', ts'') + where len = fromIntegral (T.length t) + +-- | /O(n)/ 'break' is like 'span', but the prefix returned is over +-- elements that fail the predicate @p@. +break :: (Char -> Bool) -> Text -> (Text, Text) +break p t0 = break' t0 + where break' Empty = (empty, empty) + break' c@(Chunk t ts) = + case T.findIndex p t of + Nothing -> let (ts', ts'') = break' ts + in (Chunk t ts', ts'') + Just n | n == 0 -> (Empty, c) + | otherwise -> let (a,b) = T.splitAt n t + in (Chunk a Empty, Chunk b ts) + +-- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns a +-- pair whose first element is the longest prefix (possibly empty) of +-- @t@ of elements that satisfy @p@, and whose second is the remainder +-- of the list. +span :: (Char -> Bool) -> Text -> (Text, Text) +span p = break (not . p) +{-# INLINE span #-} + +-- | The 'group' function takes a 'Text' and returns a list of 'Text's +-- such that the concatenation of the result is equal to the argument. +-- Moreover, each sublist in the result contains only equal elements. +-- For example, +-- +-- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"] +-- +-- It is a special case of 'groupBy', which allows the programmer to +-- supply their own equality test. +group :: Text -> [Text] +group = groupBy (==) +{-# INLINE group #-} + +-- | The 'groupBy' function is the non-overloaded version of 'group'. +groupBy :: (Char -> Char -> Bool) -> Text -> [Text] +groupBy _ Empty = [] +groupBy eq (Chunk t ts) = cons x ys : groupBy eq zs + where (ys,zs) = span (eq x) xs + x = T.unsafeHead t + xs = chunk (T.unsafeTail t) ts + +-- | /O(n)/ Return all initial segments of the given 'Text', +-- shortest first. +inits :: Text -> [Text] +inits = (Empty :) . inits' + where inits' Empty = [] + inits' (Chunk t ts) = L.map (\t' -> Chunk t' Empty) (L.tail (T.inits t)) + ++ L.map (Chunk t) (inits' ts) + +-- | /O(n)/ Return all final segments of the given 'Text', longest +-- first. +tails :: Text -> [Text] +tails Empty = Empty : [] +tails ts@(Chunk t ts') + | T.length t == 1 = ts : tails ts' + | otherwise = ts : tails (Chunk (T.unsafeTail t) ts') + +-- | /O(n)/ Break a 'Text' into pieces separated by the byte +-- argument, consuming the delimiter. I.e. +-- +-- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"] +-- > split 'a' "aXaXaXa" == ["","X","X","X",""] +-- > split 'x' "x" == ["",""] +-- +-- and +-- +-- > intercalate [c] . split c == id +-- > split == splitWith . (==) +-- +-- As for all splitting functions in this library, this function does +-- not copy the substrings, it just constructs new 'Text's that are +-- slices of the original. +split :: Char -> Text -> [Text] +split c = splitWith (==c) +{-# INLINE split #-} + +-- | /O(n)/ Splits a 'Text' into components delimited by separators, +-- where the predicate returns True for a separator element. The +-- resulting components do not contain the separators. Two adjacent +-- separators result in an empty component in the output. eg. +-- +-- > splitWith (=='a') "aabbaca" == ["","","bb","c",""] +-- > splitWith (=='a') [] == [] +splitWith :: (Char -> Bool) -> Text -> [Text] +splitWith _ Empty = [] +splitWith p (Chunk t0 ts0) = comb [] (T.splitWith p t0) ts0 + where comb acc (s:[]) Empty = revChunks (s:acc) : [] + comb acc (s:[]) (Chunk t ts) = comb (s:acc) (T.splitWith p t) ts + comb acc (s:ss) ts = revChunks (s:acc) : comb [] ss ts + comb _ [] _ = impossibleError "splitWith" +{-# INLINE splitWith #-} + +-- | /O(n)/ Breaks a 'Text' up into a list of 'Text's at +-- newline 'Char's. The resulting strings do not contain newlines. +lines :: Text -> [Text] +lines Empty = [] +lines t = let (l,t') = break ((==) '\n') t + in l : if null t' then [] + else lines (tail t') + +-- | /O(n)/ Breaks a 'Text' up into a list of words, delimited by 'Char's +-- representing white space. +words :: Text -> [Text] +words = L.filter (not . null) . splitWith isSpace +{-# INLINE words #-} + +-- | /O(n)/ Joins lines, after appending a terminating newline to +-- each. +unlines :: [Text] -> Text +unlines = concat . L.map (`snoc` '\n') +{-# INLINE unlines #-} + +-- | /O(n)/ Joins words using single space characters. +unwords :: [Text] -> Text +unwords = intercalate (singleton ' ') +{-# INLINE unwords #-} + +-- | /O(n)/ The 'isPrefixOf' function takes two 'Text's and returns +-- 'True' iff the first is a prefix of the second. This function is +-- subject to fusion. +isPrefixOf :: Text -> Text -> Bool +isPrefixOf Empty _ = True +isPrefixOf _ Empty = False +isPrefixOf (Chunk x xs) (Chunk y ys) + | lx == ly = x == y && isPrefixOf xs ys + | lx < ly = x == yh && isPrefixOf xs (Chunk yt ys) + | otherwise = xh == y && isPrefixOf (Chunk xt xs) ys + where (xh,xt) = T.splitAt ly x + (yh,yt) = T.splitAt lx y + lx = T.length x + ly = T.length y +{-# INLINE [1] isPrefixOf #-} + +{-# RULES +"LAZY TEXT isPrefixOf -> fused" [~1] forall s t. + isPrefixOf s t = S.isPrefixOf (stream s) (stream t) +"LAZY TEXT isPrefixOf -> unfused" [1] forall s t. + S.isPrefixOf (stream s) (stream t) = isPrefixOf s t + #-} + +-- | /O(n)/ The 'isSuffixOf' function takes two 'Text's and returns +-- 'True' iff the first is a suffix of the second. +isSuffixOf :: Text -> Text -> Bool +isSuffixOf x y = reverse x `isPrefixOf` reverse y +{-# INLINE isSuffixOf #-} +-- TODO: a better implementation + +-- | /O(n)/ The 'isInfixOf' function takes two 'Text's and returns +-- 'True' iff the first is contained, wholly and intact, anywhere +-- within the second. +isInfixOf :: Text -> Text -> Bool +isInfixOf needle haystack = L.any (isPrefixOf needle) (tails haystack) +{-# INLINE isInfixOf #-} +-- TODO: a better implementation + +-- | /O(n)/ 'elem' is the 'Text' membership predicate. +elem :: Char -> Text -> Bool +elem c t = S.elem c (stream t) +{-# INLINE elem #-} + +-- | /O(n)/ 'filter', applied to a predicate and a 'Text', +-- returns a 'Text' containing those characters that satisfy the +-- predicate. +filter :: (Char -> Bool) -> Text -> Text +filter p t = unstream (S.filter p (stream t)) +{-# INLINE filter #-} + +-- | /O(n)/ The 'find' function takes a predicate and a 'Text', +-- and returns the first element in matching the predicate, or 'Nothing' +-- if there is no such element. +find :: (Char -> Bool) -> Text -> Maybe Char +find p t = S.find p (stream t) +{-# INLINE find #-} + +-- | /O(n)/ The 'partition' function takes a predicate and a 'Text', +-- and returns the pair of 'Text's with elements which do and do not +-- satisfy the predicate, respectively; i.e. +-- +-- > partition p t == (filter p t, filter (not . p) t) +partition :: (Char -> Bool) -> Text -> (Text, Text) +partition p t = (filter p t, filter (not . p) t) +{-# INLINE partition #-} + +-- | /O(n)/ 'Text' index (subscript) operator, starting from 0. +index :: Text -> Int64 -> Char +index t n = S.index (stream t) n +{-# INLINE index #-} + +-- | /O(n)/ The 'findIndex' function takes a predicate and a 'Text' +-- and returns the index of the first element in the 'Text' satisfying +-- the predicate. This function is subject to fusion. +findIndex :: (Char -> Bool) -> Text -> Maybe Int64 +findIndex p t = S.findIndex p (stream t) +{-# INLINE findIndex #-} + +-- | The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending +-- order. This function is subject to fusion. +findIndices :: (Char -> Bool) -> Text -> [Int64] +findIndices p t = S.findIndices p (stream t) +{-# INLINE findIndices #-} + +-- | /O(n)/ The 'elemIndex' function returns the index of the first +-- element in the given 'Text' which is equal to the query element, or +-- 'Nothing' if there is no such element. This function is subject to +-- fusion. +elemIndex :: Char -> Text -> Maybe Int64 +elemIndex c t = S.elemIndex c (stream t) +{-# INLINE elemIndex #-} + +-- | /O(n)/ The 'elemIndices' function returns the index of every +-- element in the given 'Text' which is equal to the query +-- element. This function is subject to fusion. +elemIndices :: Char -> Text -> [Int64] +elemIndices c t = S.elemIndices c (stream t) +{-# INLINE elemIndices #-} + +-- | /O(n)/ The 'count' function returns the number of times the query +-- element appears in the given 'Text'. This function is subject to +-- fusion. +count :: Char -> Text -> Int64 +count c t = S.count c (stream t) +{-# INLINE count #-} + +-- | /O(n)/ 'zip' takes two 'Text's and returns a list of +-- corresponding pairs of bytes. If one input 'Text' is short, +-- excess elements of the longer 'Text' are discarded. This is +-- equivalent to a pair of 'unpack' operations. +zip :: Text -> Text -> [(Char,Char)] +zip a b = S.unstreamList $ S.zipWith (,) (stream a) (stream b) +{-# INLINE [0] zip #-} + +-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function +-- given as the first argument, instead of a tupling function. +zipWith :: (Char -> Char -> Char) -> Text -> Text -> Text +zipWith f t1 t2 = unstream (S.zipWith f (stream t1) (stream t2)) +{-# INLINE [0] zipWith #-} + +revChunks :: [T.Text] -> Text +revChunks = L.foldl' (flip chunk) Empty + +emptyError :: String -> a +emptyError fun = P.error ("Data.Text.Lazy." ++ fun ++ ": empty input") + +impossibleError :: String -> a +impossibleError fun = P.error ("Data.Text.Lazy." ++ fun ++ ": impossible case") diff --git a/Data/Text/Lazy/Encoding.hs b/Data/Text/Lazy/Encoding.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Lazy/Encoding.hs @@ -0,0 +1,48 @@ +-- | +-- Module : Data.Text.Lazy.Encoding +-- Copyright : (c) Bryan O'Sullivan 2009 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com, rtharper@aftereternity.co.uk, +-- duncan@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Functions for converting lazy 'Text' values to and from lazy +-- 'ByteString', using several standard encodings. +-- +-- To make use of a much larger variety of encodings, use the @text-icu@ +-- package. + +module Data.Text.Lazy.Encoding + ( + -- * Decoding ByteStrings to Text + -- decodeASCII + decodeUtf8 + --, decodeUtf16LE + --, decodeUtf16BE + --, decodeUtf32LE + --, decodeUtf32BE + + -- * Encoding Text to ByteStrings + , encodeUtf8 + --, encodeUtf16LE + --, encodeUtf16BE + --, encodeUtf32LE + --, encodeUtf32BE + ) where + +import Data.ByteString.Lazy (ByteString) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy.Fusion as F +import qualified Data.Text.Lazy.Encoding.Fusion as E + +-- | Decode a 'ByteString' containing UTF-8 encoded text. +decodeUtf8 :: ByteString -> Text +decodeUtf8 bs = F.unstream (E.streamUtf8 bs) +{-# INLINE decodeUtf8 #-} + +-- | Encode text using UTF-8 encoding. +encodeUtf8 :: Text -> ByteString +encodeUtf8 txt = E.unstream (E.restreamUtf8 (F.stream txt)) +{-# INLINE encodeUtf8 #-} diff --git a/Data/Text/Lazy/Encoding/Fusion.hs b/Data/Text/Lazy/Encoding/Fusion.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Lazy/Encoding/Fusion.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Data.Text.Lazy.Encoding.Fusion +-- Copyright : (c) Bryan O'Sullivan 2009 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com, rtharper@aftereternity.co.uk, +-- duncan@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Fusible 'Stream'-oriented functions for converting between lazy +-- 'Text' and several common encodings. + +module Data.Text.Lazy.Encoding.Fusion + ( + -- * Streaming + -- streamASCII + streamUtf8 + --, streamUtf16LE + --, streamUtf16BE + --, streamUtf32LE + --, streamUtf32BE + + -- * Unstreaming + , unstream + + , module Data.Text.Encoding.Fusion.Common + ) where + +import Data.ByteString.Lazy.Internal (ByteString(..), defaultChunkSize) +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import Data.Text.Encoding.Fusion.Common +import Data.Text.Fusion (Step(..), Stream(..)) +import Data.Text.Fusion.Internal (M(..), PairS(..), S(..)) +import Data.Text.UnsafeChar (unsafeChr8) +import Data.Word (Word8) +import qualified Data.Text.Encoding.Utf8 as U8 +import System.IO.Unsafe (unsafePerformIO) +import Foreign.ForeignPtr (withForeignPtr, ForeignPtr) +import Foreign.Storable (pokeByteOff) +import Data.ByteString.Internal (mallocByteString, memcpy) +import Control.Exception (assert) +import qualified Data.ByteString.Internal as B + +unknownLength :: Int +unknownLength = 4 + +-- | /O(n)/ Convert a lazy 'ByteString' into a 'Stream Char', using +-- UTF-8 encoding. +streamUtf8 :: ByteString -> Stream Char +streamUtf8 bs0 = Stream next (bs0 :!: S N N N N :!: 0) unknownLength + where + {-# INLINE next #-} + next st@(bs :!: s :!: i) = + case s of + S (J a) N _ _ | U8.validate1 a -> + Yield (unsafeChr8 a) es + S (J a) (J b) N _ | U8.validate2 a b -> + Yield (U8.chr2 a b) es + S (J a) (J b) (J c) N | U8.validate3 a b c -> + Yield (U8.chr3 a b c) es + S (J a) (J b) (J c) (J d) | U8.validate4 a b c d -> + Yield (U8.chr4 a b c d) es + _ -> consume st + where es = bs :!: S N N N N :!: i + {-# INLINE consume #-} + consume (bs@(Chunk ps rest) :!: s :!: i) + | i >= len = consume (rest :!: s :!: 0) + | otherwise = next (bs :!: s' :!: i+1) + where s' = case s of + S N _ _ _ -> S x N N N + S a N _ _ -> S a x N N + S a b N _ -> S a b x N + S a b c N -> S a b c x + _ -> encodingError "streamUtf8" "UTF-8" + x = J (B.unsafeIndex ps i) + len = B.length ps + consume (Empty :!: S N _ _ _ :!: _) = Done + consume _ = encodingError "streamUtf8" "UTF-8" +{-# INLINE [0] streamUtf8 #-} + +-- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'. +unstreamChunks :: Int -> Stream Word8 -> ByteString +unstreamChunks chunkSize (Stream next s0 len0) = chunk s0 len0 + where chunk s1 len1 = unsafePerformIO $ do + let len = min (max len1 unknownLength) chunkSize + mallocByteString len >>= loop len 0 s1 + where + loop !n !off !s fp = case next s of + Done | off == 0 -> return Empty + | otherwise -> do + bs <- trimUp fp off + return $! Chunk bs Empty + Skip s' -> loop n off s' fp + Yield x s' + | off == chunkSize -> do + bs <- trimUp fp off + return (Chunk bs (chunk s (n - B.length bs))) + | off == n -> realloc fp n off s' x + | otherwise -> do + withForeignPtr fp $ \p -> pokeByteOff p off x + loop n (off+1) s' fp + {-# NOINLINE realloc #-} + realloc fp n off s x = do + let n' = min (n+n) chunkSize + fp' <- copy0 fp n n' + withForeignPtr fp' $ \p -> pokeByteOff p off x + loop n' (off+1) s fp' + {-# NOINLINE trimUp #-} + trimUp fp off = return $! B.PS fp 0 off + copy0 :: ForeignPtr Word8 -> Int -> Int -> IO (ForeignPtr Word8) + copy0 !src !srcLen !destLen = assert (srcLen <= destLen) $ do + dest <- mallocByteString destLen + withForeignPtr src $ \src' -> + withForeignPtr dest $ \dest' -> + memcpy dest' src' (fromIntegral srcLen) + return dest + +-- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'. +unstream :: Stream Word8 -> ByteString +unstream = unstreamChunks defaultChunkSize + +encodingError :: String -> String -> a +encodingError func encoding = + error $ "Data.Text.Lazy.Encoding.Fusion." ++ func ++ ": Bad " ++ + encoding ++ " stream" diff --git a/Data/Text/Lazy/Fusion.hs b/Data/Text/Lazy/Fusion.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Lazy/Fusion.hs @@ -0,0 +1,139 @@ +-- | +-- Module : Data.Text.Lazy.Fusion +-- Copyright : (c) Bryan O'Sullivan 2009 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com, rtharper@aftereternity.co.uk, +-- duncan@haskell.org +-- Stability : experimental +-- Portability : GHC +-- +-- Core stream fusion functionality for text. + +module Data.Text.Lazy.Fusion + ( + stream + , unstream + , unstreamChunks + , length + , unfoldrN + , index + , findIndex + , findIndices + , elemIndex + , elemIndices + , count + ) where + +import Prelude hiding (length) +import qualified Data.Text.Fusion.Common as S +import Data.Text.Fusion.Internal +import Data.Text.Lazy.Internal +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.Int (Int64) + +default(Int64) + +-- | /O(n)/ Convert a 'Text' into a 'Stream Char'. +stream :: Text -> Stream Char +stream text = Stream next (text :!: 0) 4 -- random HINT + where + next (Empty :!: _) = Done + 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 +{-# INLINE [0] stream #-} + +-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using the given +-- chunk size. +unstreamChunks :: Int -> Stream Char -> Text +unstreamChunks chunkSize (Stream next s0 len0) + | len0 == 0 = Empty + | otherwise = outer s0 + where + outer s = case next s of + Done -> Empty + Skip s' -> outer s' + 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 + unknownLength = 4 + inner marr len s i + | i + 1 >= chunkSize = return (marr, (s,i)) + | i + 1 >= len = do + let newLen = min (len * 2) chunkSize + marr' <- A.unsafeNew newLen + A.copy marr marr' + 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' +{-# INLINE [0] unstreamChunks #-} + +-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using +-- 'defaultChunkSize'. +unstream :: Stream Char -> Text +unstream = unstreamChunks defaultChunkSize +{-# INLINE [0] unstream #-} + +-- | /O(n)/ Returns the number of characters in a text. +length :: Stream Char -> Int64 +length = S.lengthI +{-# INLINE[0] length #-} + +{-# RULES "LAZY STREAM stream/unstream fusion" forall s. + stream (unstream s) = s #-} + +-- | /O(n)/ Like 'unfoldr', 'unfoldrN64' 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 +-- 'unfoldr' when the length of the result is known. +unfoldrN :: Int64 -> (a -> Maybe (Char,a)) -> a -> Stream Char +unfoldrN n = S.unfoldrNI n +{-# INLINE [0] unfoldrN #-} + +-- | /O(n)/ stream index (subscript) operator, starting from 0. +index :: Stream Char -> Int64 -> Char +index = S.indexI +{-# INLINE [0] index #-} + +-- | The 'findIndex' function takes a predicate and a stream and +-- returns the index of the first element in the stream +-- satisfying the predicate. +findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int64 +findIndex = S.findIndexI +{-# INLINE [0] findIndex #-} + +-- | The 'findIndices' function takes a predicate and a stream and +-- returns all indices of the elements in the stream +-- satisfying the predicate. +findIndices :: (Char -> Bool) -> Stream Char -> [Int64] +findIndices = S.findIndicesI +{-# INLINE [0] findIndices #-} + +-- | /O(n)/ The 'elemIndex' function returns the index of the first +-- element in the given stream which is equal to the query +-- element, or 'Nothing' if there is no such element. +elemIndex :: Char -> Stream Char -> Maybe Int64 +elemIndex = S.elemIndexI +{-# INLINE [0] elemIndex #-} + +-- | /O(n)/ The 'elemIndices' function returns the index of every +-- element in the given stream which is equal to the query element. +elemIndices :: Char -> Stream Char -> [Int64] +elemIndices = S.elemIndicesI +{-# INLINE [0] elemIndices #-} + +-- | /O(n)/ The 'count' function returns the number of times the query +-- element appears in the given stream. +count :: Char -> Stream Char -> Int64 +count = S.countI +{-# INLINE [0] count #-} diff --git a/Data/Text/Lazy/Internal.hs b/Data/Text/Lazy/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Lazy/Internal.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} +-- | +-- Module : Data.Text.Lazy.Internal +-- Copyright : (c) Bryan O'Sullivan 2009 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com, rtharper@aftereternity.co.uk, +-- duncan@haskell.org +-- Stability : experimental +-- Portability : GHC +-- +-- A module containing semi-public 'Text' internals. This exposes the +-- 'Text' representation and low level construction functions. +-- Modules which extend the 'Text' system may need to use this module. +-- Regular users should not. +module Data.Text.Lazy.Internal + ( + Text(..) + , chunk + , empty + , foldrChunks + , foldlChunks + -- * Data type invariant and abstraction functions + , invariant + , checkInvariant + , showStructure + -- * Chunk allocation sizes + , defaultChunkSize + , smallChunkSize + , chunkOverhead + ) where + +import qualified Data.Text.Internal as T +import qualified Data.Text as T +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 +-- 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 + +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 #-} +chunk t@(T.Text _ _ len) ts | len == 0 = ts + | otherwise = Chunk t ts + +-- | Smart constructor for 'Empty'. +empty :: Text +{-# INLINE [0] empty #-} +empty = Empty + +-- | Consume the chunks of a lazy 'Text' with a natural right fold. +foldrChunks :: (T.Text -> a -> a) -> a -> Text -> a +foldrChunks f z = go + where go Empty = z + go (Chunk c cs) = f c (go cs) +{-# INLINE foldrChunks #-} + +-- | Consume the chunks of a lazy 'Text' with a strict, tail-recursive, +-- accumulating left fold. +foldlChunks :: (a -> T.Text -> a) -> a -> Text -> a +foldlChunks f z = go z + where go !a Empty = a + go !a (Chunk c cs) = go (f a c) cs +{-# INLINE foldlChunks #-} + +-- | Currently set to 32k, less the memory management overhead. +defaultChunkSize :: Int +defaultChunkSize = 32 * k - chunkOverhead + where k = 1024 `div` sizeOf (undefined :: Word16) + +-- | Currently set to 4k, less the memory management overhead. +smallChunkSize :: Int +smallChunkSize = 4 * k - chunkOverhead + where k = 1024 `div` sizeOf (undefined :: Word16) + +-- | The memory management overhead. Currently this is tuned for GHC only. +chunkOverhead :: Int +chunkOverhead = 2 * sizeOf (undefined :: Int) diff --git a/Data/Text/Unsafe.hs b/Data/Text/Unsafe.hs --- a/Data/Text/Unsafe.hs +++ b/Data/Text/Unsafe.hs @@ -2,7 +2,8 @@ -- Module : Data.Text.Unsafe -- Copyright : (c) Bryan O'Sullivan 2009 -- License : BSD-style --- Maintainer : bos@serpentine.com +-- Maintainer : bos@serpentine.com, rtharper@aftereternity.co.uk, +-- duncan@haskell.org -- Stability : experimental -- Portability : portable -- diff --git a/Data/Text/UnsafeChar.hs b/Data/Text/UnsafeChar.hs --- a/Data/Text/UnsafeChar.hs +++ b/Data/Text/UnsafeChar.hs @@ -7,7 +7,7 @@ -- (c) Duncan Coutts 2009 -- -- License : BSD-style --- Maintainer : rtharper@aftereternity.co.uk, bos@serpentine.com, +-- Maintainer : bos@serpentine.com, rtharper@aftereternity.co.uk, -- duncan@haskell.org -- Stability : experimental -- Portability : GHC diff --git a/text.cabal b/text.cabal --- a/text.cabal +++ b/text.cabal @@ -1,5 +1,5 @@ name: text -version: 0.1 +version: 0.2 synopsis: An efficient packed Unicode text type description: An efficient packed Unicode text type. license: BSD3 @@ -8,7 +8,7 @@ maintainer: Bryan O'Sullivan Tom Harper Duncan Coutts -copyright: 2008-2009 Tom Harper +copyright: 2008-2009 Tom Harper, 2009 Bryan O'Sullivan category: Data, Text build-type: Simple cabal-version: >= 1.2 @@ -21,9 +21,17 @@ Data.Text.Encoding.Fusion Data.Text.Foreign Data.Text.Fusion + Data.Text.Fusion.Common + Data.Text.Lazy + Data.Text.Lazy.Encoding + Data.Text.Lazy.Encoding.Fusion + Data.Text.Lazy.Fusion other-modules: Data.Text.Array Data.Text.Internal + Data.Text.Encoding.Fusion.Common + Data.Text.Fusion.Internal + Data.Text.Lazy.Internal Data.Text.Unsafe Data.Text.UnsafeChar Data.Text.Encoding.Utf8