diff --git a/Data/Text.hs b/Data/Text.hs new file mode 100644 --- /dev/null +++ b/Data/Text.hs @@ -0,0 +1,982 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Data.Text +-- 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 : GHC +-- +-- A time and space-efficient implementation of Unicode text using +-- packed Word16 arrays. Suitable for performance critical use, both +-- in terms of large data quantities and high speed. +-- +-- This module is intended to be imported @qualified@, to avoid name +-- clashes with "Prelude" functions, e.g. +-- +-- > import qualified Data.Text as T + +module Data.Text + ( + -- * Fusion + -- $fusion + + -- * Types + Text + + -- * Creation and elimination + , pack + , unpack + , singleton + , empty + + -- * 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 + --, lines' + , words + , unlines + , unwords + + -- * Predicates + , isPrefixOf + , isSuffixOf + , isInfixOf + + -- * Searching + , elem + , filter + , find + , partition + + -- , findSubstring + + -- * Indexing + , index + , findIndex + , findIndices + , elemIndex + , elemIndices + , count + + -- * Zipping and unzipping + , zipWith + + -- -* Ordered text + , -- sort + ) where + +import Prelude (Char, Bool(..), Functor(..), Int, Maybe(..), String, + Eq(..), (++), + Read(..), Show(..), + (&&), (||), (+), (-), (<), (>), (<=), (>=), (.), ($), + not, return, otherwise) +import Control.Exception (assert) +import Data.Char (isSpace) +import Control.Monad.ST (ST) +import qualified Data.Text.Array as A +import qualified Data.List as L +import Data.Monoid (Monoid(..)) +import Data.Word (Word16) +import Data.String (IsString(..)) + +import qualified Data.Text.Fusion as S +import Data.Text.Fusion (Stream(..), Step(..), stream, reverseStream, unstream) +import Data.Text.Internal (Text(..), empty, text) +import qualified Prelude as P +import Data.Text.Unsafe (iter, iter_, unsafeHead, unsafeTail) +import Data.Text.UnsafeChar (unsafeChr) +import qualified Data.Text.Encoding.Utf16 as U16 + +-- $fusion +-- +-- Most of the functions in this module are subject to /array fusion/, +-- meaning that a pipeline of functions will usually allocate at most +-- one 'Text' value. + +instance Eq Text where + t1 == t2 = (stream t1) `S.eq` (stream t2) + +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 Monoid Text where + mempty = empty + mappend = append + mconcat = concat + +instance IsString Text where + fromString = pack + +-- ----------------------------------------------------------------------------- +-- * Conversion to/from 'Text' + +-- | /O(n)/ Convert a 'String' into a 'Text'. +-- +-- 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 +{-# 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' +{-# 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 +{-# INLINE [1] singleton #-} + +-- ----------------------------------------------------------------------------- +-- * Basic functions + +-- | /O(n)/ Adds a character to the front of a 'Text'. This function +-- is more costly than its 'List' counterpart because it requires +-- copying a new array. Subject to array fusion. +cons :: Char -> Text -> Text +cons c t = unstream (S.cons c (stream t)) +{-# INLINE cons #-} + +-- | /O(n)/ Adds a character to the end of a 'Text'. This copies the +-- entire array in the process. Subject to array fusion. +snoc :: Text -> Char -> Text +snoc t c = unstream (S.snoc (stream t) c) +{-# INLINE snoc #-} + +-- | /O(n)/ Appends one 'Text' to the other by copying both of them +-- into a new 'Text'. Subject to array fusion. +append :: Text -> Text -> Text +append (Text arr1 off1 len1) (Text arr2 off2 len2) = Text (A.run x) 0 len + where + len = len1+len2 + x = do + arr <- A.unsafeNew len :: ST s (A.MArray s Word16) + copy arr1 off1 (len1+off1) arr 0 + copy arr2 off2 (len2+off2) arr len1 + return arr + where + copy arr i max arr' j + | i >= max = return () + | otherwise = do A.unsafeWrite arr' j (arr `A.unsafeIndex` i) + copy arr (i+1) max arr' (j+1) +{-# INLINE append #-} + +{-# RULES +"TEXT append -> fused" [~1] forall t1 t2. + append t1 t2 = unstream (S.append (stream t1) (stream t2)) +"TEXT append -> unfused" [1] forall t1 t2. + unstream (S.append (stream t1) (stream t2)) = append t1 t2 + #-} + +-- | /O(1)/ Returns the first character of a 'Text', which must be +-- non-empty. Subject to array fusion. +head :: Text -> Char +head t = S.head (stream t) +{-# INLINE head #-} + +-- | /O(1)/ Returns the first character and rest of a 'Text', or +-- 'Nothing' if empty. Subject to array fusion. +uncons :: Text -> Maybe (Char, Text) +uncons t@(Text arr off len) + | len <= 0 = Nothing + | otherwise = Just (c, textP arr (off+d) (len-d)) + where (c,d) = iter t 0 +{-# INLINE uncons #-} + +-- | Lifted from Control.Arrow and specialized. +second :: (b -> c) -> (a,b) -> (a,c) +second f (a, b) = (a, f b) + +{-# RULES +"TEXT uncons -> fused" [~1] forall t. + uncons t = fmap (second unstream) (S.uncons (stream t)) +"TEXT uncons -> unfused" [1] forall t. + fmap (second unstream) (S.uncons (stream t)) = uncons t + #-} + +-- | /O(1)/ Returns the last character of a 'Text', which must be +-- non-empty. Subject to array fusion. +last :: Text -> Char +last (Text arr off len) + | len <= 0 = emptyError "last" + | n < 0xDC00 || n > 0xDFFF = unsafeChr n + | otherwise = U16.chr2 n0 n + where n = A.unsafeIndex arr (off+len-1) + n0 = A.unsafeIndex arr (off+len-2) +{-# INLINE [1] last #-} + +{-# RULES +"TEXT last -> fused" [~1] forall t. + last t = S.last (stream t) +"TEXT last -> unfused" [1] forall t. + S.last (stream t) = last t + #-} + +-- | 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 +tail t@(Text arr off len) + | len <= 0 = emptyError "tail" + | otherwise = textP arr (off+d) (len-d) + where d = iter_ t 0 +{-# INLINE [1] tail #-} + +{-# RULES +"TEXT tail -> fused" [~1] forall t. + tail t = unstream (S.tail (stream t)) +"TEXT tail -> unfused" [1] forall t. + unstream (S.tail (stream t)) = tail t + #-} + +-- | /O(1)/ Returns all but the last character of a 'Text', which must +-- be non-empty. Subject to array fusion. +init :: Text -> Text +init (Text arr off len) | len <= 0 = emptyError "init" + | n >= 0xDC00 && n <= 0xDFFF = textP arr off (len-2) + | otherwise = textP arr off (len-1) + where + n = A.unsafeIndex arr (off+len-1) +{-# INLINE [1] init #-} + +{-# RULES +"TEXT init -> fused" [~1] forall t. + init t = unstream (S.init (stream t)) +"TEXT init -> unfused" [1] forall t. + unstream (S.init (stream t)) = init t + #-} + +-- | /O(1)/ Tests whether a 'Text' is empty or not. Subject to array +-- fusion. +null :: Text -> Bool +null (Text _arr _off len) = assert (len >= 0) $ len <= 0 +{-# INLINE [1] null #-} + +{-# RULES +"TEXT null -> fused" [~1] forall t. + null t = S.null (stream t) +"TEXT null -> unfused" [1] forall t. + S.null (stream t) = null t + #-} + +-- | /O(n)/ Returns the number of characters in a 'Text'. +-- Subject to array fusion. +length :: Text -> Int +length t = S.length (stream t) +{-# INLINE length #-} + +-- ----------------------------------------------------------------------------- +-- * Transformations +-- | /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)/ Reverse the characters of a string. Subject to array fusion. +reverse :: Text -> Text +reverse t = S.reverse (stream t) +{-# INLINE reverse #-} + +-- | /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 = P.map pack (L.transpose (P.map unpack ts)) + +-- ----------------------------------------------------------------------------- +-- * Reducing 'Text's (folds) + +-- | /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 #-} + +-- ----------------------------------------------------------------------------- +-- ** Special folds + +-- | /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 #-} + +-- ----------------------------------------------------------------------------- +-- * Building 'Text's + +-- | /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 t | null t = empty + | otherwise = scanl f (unsafeHead t) (unsafeTail t) +{-# INLINE scanl1 #-} + +-- | /O(n)/ 'scanr' is the right-to-left dual of 'scanl'. +-- +-- > scanr f v t == reverse (scanl (flip f) v t) +scanr :: (Char -> Char -> Char) -> Char -> Text -> Text +scanr f z = S.reverse . S.reverseScanr f z . reverseStream +{-# INLINE scanr #-} + +-- | /O(n)/ 'scanr1' is a variant of 'scanr' that has no starting +-- value argument. This function is subject to array fusion. +scanr1 :: (Char -> Char -> Char) -> Text -> Text +scanr1 f t | null t = empty + | otherwise = scanr f (last t) (init t) +{-# INLINE scanr1 #-} + +-- | /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 + +-- ----------------------------------------------------------------------------- +-- ** Generating and unfolding 'Text's + +-- | /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 :: Int -> (a -> Maybe (Char,a)) -> a -> Text +unfoldrN n f s = unstream (S.unfoldrN n f s) +{-# INLINE unfoldrN #-} + +-- ----------------------------------------------------------------------------- +-- * Substrings + +-- | /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. +take :: Int -> Text -> Text +take n t@(Text arr off len) + | n <= 0 = empty + | n >= len = t + | otherwise = Text arr off (loop 0 0) + where + loop !i !cnt + | i >= len || cnt >= n = i + | otherwise = loop (i+d) (cnt+1) + where d = iter_ t i +{-# INLINE [1] take #-} + +{-# RULES +"TEXT take -> fused" [~1] forall n t. + take n t = unstream (S.take n (stream t)) +"TEXT take -> unfused" [1] forall n t. + unstream (S.take n (stream t)) = take n t + #-} + +-- | /O(n)/ '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'. +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) + | otherwise = loop (i+d) (cnt+1) + where d = iter_ t i +{-# INLINE [1] drop #-} + +{-# RULES +"TEXT drop -> fused" [~1] forall n t. + drop n t = unstream (S.drop n (stream t)) +"TEXT drop -> unfused" [1] forall n t. + unstream (S.drop n (stream t)) = drop n t + #-} + +-- | /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 t@(Text arr off len) = loop 0 + where loop !i | i >= len = t + | p c = loop (i+d) + | otherwise = textP arr off i + where (c,d) = iter t i +{-# INLINE [1] takeWhile #-} + +{-# RULES +"TEXT takeWhile -> fused" [~1] forall p t. + takeWhile p t = unstream (S.takeWhile p (stream t)) +"TEXT takeWhile -> unfused" [1] forall p t. + unstream (S.takeWhile p (stream t)) = takeWhile p t + #-} + +-- | /O(n)/ '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 t@(Text arr off len) = loop 0 0 + where loop !i !l | l >= len = empty + | p c = loop (i+d) (l+d) + | otherwise = Text arr (off+i) (len-l) + where (c,d) = iter t i +{-# INLINE [1] dropWhile #-} + +{-# RULES +"TEXT dropWhile -> fused" [~1] forall p t. + dropWhile p t = unstream (S.dropWhile p (stream t)) +"TEXT dropWhile -> unfused" [1] forall p t. + unstream (S.dropWhile p (stream t)) = dropWhile p t + #-} + +-- | /O(n)/ '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 :: Int -> Text -> (Text, Text) +splitAt n t@(Text arr off len) + | n <= 0 = (empty, t) + | n >= len = (t, empty) + | otherwise = (Text arr off k, Text arr (off+k) (len-k)) + where k = loop 0 0 + loop !i !cnt + | i >= len || cnt >= n = i + | otherwise = loop (i+d) (cnt+1) + where d = iter_ t i +{-# INLINE splitAt #-} + +-- | /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 t@(Text arr off len) = (textP arr off k, textP arr (off+k) (len-k)) + where k = loop 0 + loop !i | i >= len || not (p c) = i + | otherwise = loop (i+d) + where (c,d) = iter t i +{-# INLINE span #-} + +-- | /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 = span (not . p) +{-# INLINE break #-} + +-- | /O(n)/ Group characters in a string according to a predicate. +groupBy :: (Char -> Char -> Bool) -> Text -> [Text] +groupBy p = loop + where + loop t@(Text arr off len) + | null t = [] + | otherwise = text arr off n : loop (text arr (off+n) (len-n)) + where (c,d) = iter t 0 + n = d + findAIndexOrEnd (not . p c) (Text arr (off+d) (len-d)) + +-- | Returns the /array/ index (in units of 'Word16') at which a +-- character may be found. This is /not/ the same as the logical +-- index returned by e.g. 'findIndex'. +findAIndexOrEnd :: (Char -> Bool) -> Text -> Int +findAIndexOrEnd q t@(Text _arr _off len) = go 0 + where go !i | i >= len || q c = i + | otherwise = go (i+d) + where (c,d) = iter t i + +-- | /O(n)/ Group characters in a string by equality. +group :: Text -> [Text] +group = groupBy (==) + +-- | /O(n)/ Return all initial segments of the given 'Text', shortest +-- first. +inits :: Text -> [Text] +inits t@(Text arr off len) = loop 0 + where loop i | i >= len = [t] + | otherwise = Text arr off i : loop (i + iter_ t i) + +-- | /O(n)/ Return all final segments of the given 'Text', longest +-- first. +tails :: Text -> [Text] +tails t | null t = [empty] + | otherwise = t : tails (unsafeTail t) + +-- | /O(n)/ Break a 'Text' into pieces separated by the 'Char' +-- 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 (singleton 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 p = loop + where loop s | null s = [] + | otherwise = if null s' + then [s] + else l : loop (unsafeTail s') + where (l, s') = break p s +{-# INLINE splitWith #-} + +-- ---------------------------------------------------------------------------- +-- * Searching + +------------------------------------------------------------------------------- +-- ** Searching by equality + +-- | /O(n)/ 'elem' is the 'Text' membership predicate. +elem :: Char -> Text -> Bool +elem c t = S.elem c (stream t) +{-# INLINE elem #-} + +------------------------------------------------------------------------------- +-- ** Searching with a predicate + +-- | /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)/ Break a string on a substring, returning a pair of the +-- part of the string prior to the match, and the rest of the string. +-- +-- The following relationship holds: +-- +-- > break (==c) l == breakSubstring (singleton c) l +-- +-- For example, to tokenise a string, dropping delimiters: +-- +-- > tokenise x y = h : if null t then [] else tokenise x (drop (length x) t) +-- > where (h,t) = breakSubstring x y +-- +-- To skip to the first occurence of a string: +-- +-- > snd (breakSubstring x y) +-- +-- To take the parts of a string before a delimiter: +-- +-- > fst (breakSubstring x y) +-- +breakSubstring :: Text -- ^ String to search for + -> Text -- ^ String to search in + -> (Text,Text) -- ^ Head and tail of string broken at substring + +breakSubstring pat src = search 0 src + where + search !n !s + | null s = (src,empty) -- not found + | pat `isPrefixOf` s = (take n src,s) + | otherwise = search (n+1) (unsafeTail s) +{-# INLINE breakSubstring #-} + +-- | /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 #-} + + +------------------------------------------------------------------------------- +-- ** Indexing 'Text's + +-- | /O(1)/ 'Text' index (subscript) operator, starting from 0. +index :: Text -> Int -> Char +index t n = S.index (stream t) n +{-# INLINE index #-} + +-- | /O(n)/ The 'findIndex' function takes a predicate and a 'Text' +-- and returns the index of the first element in the 'Text' satisfying +-- the predicate. This function is subject to fusion. +findIndex :: (Char -> Bool) -> Text -> Maybe Int +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 -> [Int] +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 Int +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 -> [Int] +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 -> Int +count c t = S.count c (stream t) +{-# INLINE count #-} + +------------------------------------------------------------------------------- +-- * Zipping + +-- | /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)) + +-- | /O(n)/ Breaks a 'Text' up into a list of words, delimited by 'Char's +-- representing white space. +words :: Text -> [Text] +words t@(Text arr off len) = loop 0 0 + where + loop !start !n + | n >= len = if start == n + then [] + else [Text arr (start+off) (n-start)] + | isSpace c = + if start == n + then loop (start+1) (start+1) + else Text arr (start+off) (n-start) : loop (n+d) (n+d) + | otherwise = loop start (n+d) + where (c,d) = iter t n +{-# INLINE words #-} + +-- | /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 ps | null ps = [] + | otherwise = h : if null t + then [] + else lines (unsafeTail t) + where (h,t) = span (/= '\n') ps +{-# INLINE lines #-} + +-- | /O(n)/ Portably breaks a 'Text' up into a list of 'Text's at line +-- boundaries. +-- +-- A line boundary is considered to be either a line feed, a carriage +-- return immediately followed by a line feed, or a carriage return. +-- This accounts for both Unix and Windows line ending conventions, +-- and for the old convention used on Mac OS 9 and earlier. +{- +lines' :: Text -> [Text] +lines' ps | null ps = [] + | otherwise = h : case uncons t of + Nothing -> [] + Just (c,t') + | c == '\n' -> lines t' + | c == '\r' -> case uncons t' of + Just ('\n',t'') -> lines t'' + _ -> lines t' + where (h,t) = span notEOL ps + notEOL c = c /= '\n' && c /= '\r' +{-# INLINE lines' #-} +-} + +-- | /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 a@(Text _ _ alen) b@(Text _ _ blen) = + alen <= blen && S.isPrefixOf (stream a) (stream b) +{-# INLINE [1] isPrefixOf #-} + +{-# RULES +"TEXT isPrefixOf -> fused" [~1] forall s t. + isPrefixOf s t = S.isPrefixOf (stream s) (stream t) +"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 a@(Text _aarr _aoff alen) b@(Text barr boff blen) = + d >= 0 && a == b' + where d = blen - alen + b' | d == 0 = b + | otherwise = Text barr (boff+d) alen +{-# INLINE isSuffixOf #-} + +-- | /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 #-} + +emptyError :: String -> a +emptyError fun = P.error ("Data.Text." ++ fun ++ ": empty input") diff --git a/Data/Text/Array.hs b/Data/Text/Array.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Array.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE BangPatterns, CPP, ExistentialQuantification, MagicHash, + Rank2Types, ScopedTypeVariables, UnboxedTuples #-} +-- | +-- Module : Data.Text.Array +-- Copyright : (c) Bryan O'Sullivan 2009 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com, +-- Stability : experimental +-- Portability : portable +-- +-- Packed, unboxed, heap-resident arrays. Suitable for performance +-- critical use, both in terms of large data quantities and high +-- speed. +-- +-- This module is intended to be imported @qualified@, to avoid name +-- clashes with "Prelude" functions, e.g. +-- +-- > import qualified Data.Text.Array as A +-- +-- The names in this module resemble those in the 'Data.Array' family +-- of modules, but are shorter due to the assumption of qualifid +-- naming. +module Data.Text.Array + ( + -- * Types + IArray(..) + , Elt(..) + , Array + , MArray + + -- * Functions + , empty + , new + , unsafeNew + , unsafeFreeze + , run + , run2 + , toList + , copy + , unsafeCopy + ) where + +#if 0 +#define BOUNDS_CHECKING +-- This fugly hack is brought by GHC's apparent reluctance to deal +-- with MagicHash and UnboxedTuples when inferring types. Eek! +#define CHECK_BOUNDS(_func_,_len_,_k_) \ +if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.Text.Array." ++ (_func_) ++ ": bounds error, offset " ++ show (_k_) ++ ", length " ++ show (_len_)) else +#else +#define CHECK_BOUNDS(_func_,_len_,_k_) +#endif + +#if defined(__GLASGOW_HASKELL__) +#include "MachDeps.h" + +import GHC.Base (ByteArray#, MutableByteArray#, Int(..), indexIntArray#, + indexWord16Array#, newByteArray#, readIntArray#, + readWord16Array#, unsafeCoerce#, writeIntArray#, + writeWord16Array#, (+#), (*#)) +import GHC.Prim (Int#) +import GHC.ST (ST(..), runST) +import GHC.Word (Word16(..)) + +#elif defined(__HUGS__) + +import Hugs.ByteArray (ByteArray, MutableByteArray, readByteArray, + newMutableByteArray, readMutableByteArray, + unsafeFreezeMutableByteArray, writeMutableByteArray) +import Foreign.Storable (Storable, sizeOf) +import Hugs.ST (ST(..), runST) + +#else +# error not implemented for this compiler +#endif + +import Control.Exception (assert) +import Data.Typeable (Typeable1(..), Typeable2(..), TyCon, mkTyCon, mkTyConApp) +import Data.Word (Word16) +import Prelude hiding (length, read) + +#include "Typeable.h" + +-- | Immutable array type. +data Array e = Array + {-# UNPACK #-} !Int -- length (in units of e, not bytes) +#if defined(__GLASGOW_HASKELL__) + ByteArray# +#elif defined(__HUGS__) + !ByteArray +#endif + +INSTANCE_TYPEABLE1(Array,arrayTc,"Array") + +-- | Mutable array type, for use in the ST monad. +data MArray s e = MArray + {-# UNPACK #-} !Int -- length (in units of e, not bytes) +#if defined(__GLASGOW_HASKELL__) + (MutableByteArray# s) +#elif defined(__HUGS__) + !(MutableByteArray s) +#endif + +INSTANCE_TYPEABLE2(MArray,mArrayTc,"MArray") + +-- | Operations supported by all arrays. +class IArray a where + -- | Return the length of an array. + length :: a -> Int + +instance IArray (Array e) where + length (Array len _ba) = len + {-# INLINE length #-} + +instance (Elt e, Show e) => Show (Array e) where + show = show . toList + +instance IArray (MArray s e) where + length (MArray len _ba) = len + {-# INLINE length #-} + +check :: IArray a => String -> a -> Int -> (a -> Int -> b) -> b +check func ary i f + | i >= 0 && i < length ary = f ary i + | otherwise = error ("Data.Array.Flat." ++ func ++ ": index out of bounds") +{-# INLINE check #-} + +-- | Operations supported by all elements that can be stored in +-- arrays. +class Elt e where + -- | Indicate how many bytes would be used for an array of the + -- given size. + bytesInArray :: Int -> e -> Int + -- | Unchecked read of an immutable array. May return garbage or + -- crash on an out-of-bounds access. + unsafeIndex :: Array e -> Int -> e + -- | Unchecked read of a mutable array. May return garbage or + -- crash on an out-of-bounds access. + unsafeRead :: MArray s e -> Int -> ST s e + -- | Unchecked write of a mutable array. May return garbage or + -- crash on an out-of-bounds access. + unsafeWrite :: MArray s e -> Int -> e -> ST s () + + -- | Read an immutable array. An invalid index results in a + -- runtime error. + index :: Array e -> Int -> e + index ary i = check "index" ary i unsafeIndex + {-# INLINE index #-} + + -- | Read a mutable array. An invalid index results in a runtime + -- error. + read :: Array e -> Int -> ST s e + read ary i = check "read" ary i read + {-# INLINE read #-} + + -- | Write a mutable array. An invalid index results in a runtime + -- error. + write :: Array e -> Int -> ST s e + write ary i = check "write" ary i write + {-# INLINE write #-} + +-- | Freeze a mutable array. Do not mutate the 'MArray' afterwards! +unsafeFreeze :: MArray s e -> ST s (Array e) + +#if defined(__GLASGOW_HASKELL__) + +iNT_SCALE :: Int# -> Int# +iNT_SCALE n# = scale# *# n# where I# scale# = SIZEOF_INT + +wORD16_SCALE :: Int# -> Int# +wORD16_SCALE n# = scale# *# n# where I# scale# = SIZEOF_WORD16 + +-- | Create an uninitialized mutable array. +unsafeNew :: forall s e. Elt e => Int -> ST s (MArray s e) +unsafeNew n = assert (n >= 0) . ST $ \s1# -> + case bytesInArray n (undefined :: e) of + len@(I# len#) -> +#if defined(BOUNDS_CHECKING) + if len < 0 then error (show ("unsafeNew",len)) else +#endif + case newByteArray# len# s1# of + (# s2#, marr# #) -> (# s2#, MArray n marr# #) +{-# INLINE unsafeNew #-} + +unsafeFreeze (MArray len mba#) = ST $ \s# -> + (# s#, Array len (unsafeCoerce# mba#) #) +{-# INLINE unsafeFreeze #-} + +-- | Create a mutable array, with its elements initialized with the +-- given value. +new :: forall s e. Elt e => Int -> e -> ST s (MArray s e) + +#elif defined(__HUGS__) + +unsafeIndexArray :: Storable e => Array e -> Int -> e +unsafeIndexArray (Array off len arr) i = + assert (i >= 0 && i < len) $ readByteArray arr (off + i) + +unsafeReadMArray :: Storable e => MArray s e -> Int -> ST s e +unsafeReadMArray (MArray _len marr) i = + assert (i >= 0 && i < len) $ readMutableByteArray marr + +unsafeWriteMArray :: Storable e => MArray s e -> Int -> e -> ST s () +unsafeWriteMArray (MArray len marr) i = + assert (i >= 0 && i < len) $ writeMutableByteArray marr + +-- | Create an uninitialized mutable array. +unsafeNew :: (Storable e) => Int -> ST s (MArray s e) +unsafeNew n = new undefined + where new :: (Storable e) => e -> ST s (MArray s e) + new unused = do + marr <- newMutableByteArray (n * sizeOf unused) + return (MArray n marr) + +unsafeFreeze (MArray len mba) = do + ba <- unsafeFreezeMutableByteArray mba + return (Array 0 len ba) + +-- | Create a mutable array, with its elements initialized with the +-- given value. +new :: (Storable e) => Int -> e -> ST s (MArray s e) +#endif + +new len initVal = do + marr <- unsafeNew len + sequence_ [unsafeWrite marr i initVal | i <- [0..len-1]] + return marr + +instance Elt Int where +#if defined(__GLASGOW_HASKELL__) + + bytesInArray (I# i#) _ = I# (iNT_SCALE i#) + {-# INLINE bytesInArray #-} + + unsafeIndex (Array len ba#) i@(I# i#) = + CHECK_BOUNDS("unsafeIndex",len,i) + case indexIntArray# ba# i# of r# -> (I# r#) + {-# INLINE unsafeIndex #-} + + unsafeRead (MArray len mba#) i@(I# i#) = ST $ \s# -> + CHECK_BOUNDS("unsafeRead",len,i) + case readIntArray# mba# i# s# of + (# s2#, r# #) -> (# s2#, I# r# #) + {-# INLINE unsafeRead #-} + + unsafeWrite (MArray len marr#) i@(I# i#) (I# e#) = ST $ \s1# -> + CHECK_BOUNDS("unsafeWrite",len,i) + case writeIntArray# marr# i# e# s1# of + s2# -> (# s2#, () #) + {-# INLINE unsafeWrite #-} + +#elif defined(__HUGS__) + + bytesInArray n w = sizeOf w * n + unsafeIndex = unsafeIndexArray + unsafeRead = unsafeReadMArray + unsafeWrite = unsafeWriteMArray + +#endif + +instance Elt Word16 where +#if defined(__GLASGOW_HASKELL__) + + bytesInArray (I# i#) _ = I# (wORD16_SCALE i#) + {-# INLINE bytesInArray #-} + + unsafeIndex (Array len ba#) i@(I# i#) = + CHECK_BOUNDS("unsafeIndex",len,i) + case indexWord16Array# ba# i# of r# -> (W16# r#) + {-# INLINE unsafeIndex #-} + + unsafeRead (MArray len mba#) i@(I# i#) = ST $ \s# -> + CHECK_BOUNDS("unsafeRead",len,i) + case readWord16Array# mba# i# s# of + (# s2#, r# #) -> (# s2#, W16# r# #) + {-# INLINE unsafeRead #-} + + unsafeWrite (MArray len marr#) i@(I# i#) (W16# e#) = ST $ \s1# -> + CHECK_BOUNDS("unsafeWrite",len,i) + case writeWord16Array# marr# i# e# s1# of + s2# -> (# s2#, () #) + {-# INLINE unsafeWrite #-} + +#elif defined(__HUGS__) + + bytesInArray n w = sizeOf w * n + unsafeIndex = unsafeIndexArray + unsafeRead = unsafeReadMArray + unsafeWrite = unsafeWriteMArray + +#endif + +-- | Convert an immutable array to a list. +toList :: Elt e => Array e -> [e] +toList a = loop 0 + where loop i | i < len = unsafeIndex a i : loop (i+1) + | otherwise = [] + len = length a + +-- | An empty immutable array. +empty :: Elt e => Array e +empty = runST (unsafeNew 0 >>= unsafeFreeze) + +-- | Run an action in the ST monad and return an immutable array of +-- its result. +run :: Elt e => (forall s. ST s (MArray s e)) -> Array e +run k = runST (k >>= unsafeFreeze) + +-- | Run an action in the ST monad and return an immutable array of +-- its result paired with whatever else the action returns. +run2 :: Elt e => (forall s. ST s (MArray s e, a)) -> (Array e, a) +run2 k = runST (do + (marr,b) <- k + arr <- unsafeFreeze marr + return (arr,b)) + +-- | Copy an array in its entirety. The destination array must be at +-- least as big as the source. +copy :: Elt e => MArray s e -- ^ source array + -> MArray s e -- ^ destination array + -> ST s () +copy src dest + | length dest >= length src = copy_loop 0 + | otherwise = fail "Data.Text.Array.copy: array too small" + where + len = length src + copy_loop i + | i >= len = return () + | otherwise = do unsafeRead src i >>= unsafeWrite dest i + copy_loop (i+1) +{-# INLINE copy #-} + +-- | Unsafely copy the elements of an array. +unsafeCopy :: Elt e => + MArray s e -> Int -> MArray s e -> Int -> Int -> ST s () +unsafeCopy src sidx dest didx count = + assert (sidx + count <= length src) . + assert (didx + count <= length dest) $ + copy_loop sidx didx 0 + where + copy_loop !i !j !c + | c >= count = return () + | otherwise = do unsafeRead src i >>= unsafeWrite dest j + copy_loop (i+1) (j+1) (c+1) +{-# INLINE unsafeCopy #-} diff --git a/Data/Text/Encoding.hs b/Data/Text/Encoding.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Encoding.hs @@ -0,0 +1,95 @@ +-- | +-- Module : Data.Text.Encoding +-- 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 +-- +-- Functions for converting 'Text' values to and from 'ByteString', +-- using several standard encodings. +-- +-- To make use of a much larger variety of encodings, use the @text-icu@ +-- package. + +module Data.Text.Encoding + ( + -- * Decoding ByteStrings to Text + decodeASCII + , decodeUtf8 + , decodeUtf16LE + , decodeUtf16BE + , decodeUtf32LE + , decodeUtf32BE + + -- * Encoding Text to ByteStrings + , encodeUtf8 + , encodeUtf16LE + , encodeUtf16BE + , encodeUtf32LE + , encodeUtf32BE + ) where + +import Data.ByteString (ByteString) +import qualified Data.Text.Fusion as F +import qualified Data.Text.Encoding.Fusion as E +import Data.Text.Internal (Text) + +-- | Decode a 'ByteString' containing 7-bit ASCII encoded text. +decodeASCII :: ByteString -> Text +decodeASCII bs = F.unstream (E.streamASCII bs) +{-# INLINE decodeASCII #-} + +-- | 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 #-} + +-- | Decode text from little endian UTF-16 encoding. +decodeUtf16LE :: ByteString -> Text +decodeUtf16LE bs = F.unstream (E.streamUtf16LE bs) +{-# INLINE decodeUtf16LE #-} + +-- | Decode text from big endian UTF-16 encoding. +decodeUtf16BE :: ByteString -> Text +decodeUtf16BE bs = F.unstream (E.streamUtf16BE bs) +{-# INLINE decodeUtf16BE #-} + +-- | Encode text using little endian UTF-16 encoding. +encodeUtf16LE :: Text -> ByteString +encodeUtf16LE txt = E.unstream (E.restreamUtf16LE (F.stream txt)) +{-# INLINE encodeUtf16LE #-} + +-- | Encode text using big endian UTF-16 encoding. +encodeUtf16BE :: Text -> ByteString +encodeUtf16BE txt = E.unstream (E.restreamUtf16BE (F.stream txt)) +{-# INLINE encodeUtf16BE #-} + +-- | Decode text from little endian UTF-32 encoding. +decodeUtf32LE :: ByteString -> Text +decodeUtf32LE bs = F.unstream (E.streamUtf32LE bs) +{-# INLINE decodeUtf32LE #-} + +-- | Decode text from big endian UTF-32 encoding. +decodeUtf32BE :: ByteString -> Text +decodeUtf32BE bs = F.unstream (E.streamUtf32BE bs) +{-# INLINE decodeUtf32BE #-} + +-- | Encode text using little endian UTF-32 encoding. +encodeUtf32LE :: Text -> ByteString +encodeUtf32LE txt = E.unstream (E.restreamUtf32LE (F.stream txt)) +{-# INLINE encodeUtf32LE #-} + +-- | Encode text using big endian UTF-32 encoding. +encodeUtf32BE :: Text -> ByteString +encodeUtf32BE txt = E.unstream (E.restreamUtf32BE (F.stream txt)) +{-# INLINE encodeUtf32BE #-} diff --git a/Data/Text/Encoding/Fusion.hs b/Data/Text/Encoding/Fusion.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Encoding/Fusion.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Data.Text.Encoding +-- 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 + ( + -- * Streaming + streamASCII + , streamUtf8 + , streamUtf16LE + , streamUtf16BE + , streamUtf32LE + , streamUtf32BE + + -- * Unstreaming + , unstream + + -- * Restreaming + -- Restreaming is the act of converting from one 'Stream' + -- representation to another. + , restreamUtf8 + , restreamUtf16LE + , restreamUtf16BE + , restreamUtf32LE + , restreamUtf32BE + ) where + +import Control.Exception (assert) +import Data.Bits (shiftL, shiftR, (.&.)) +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.UnsafeChar (unsafeChr, unsafeChr8, unsafeChr32) +import Data.Word (Word8, Word16, Word32) +import Foreign.ForeignPtr (withForeignPtr, ForeignPtr) +import Foreign.Storable (pokeByteOff) +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.Text.Encoding.Utf8 as U8 +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 + l = B.length bs + {-# INLINE next #-} + next i + | i >= l = Done + | otherwise = Yield (unsafeChr8 x1) (i+1) + where + x1 = B.unsafeIndex bs i +{-# INLINE [0] streamASCII #-} + +-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using UTF-8 +-- encoding. +streamUtf8 :: ByteString -> Stream Char +streamUtf8 bs = Stream next 0 l + where + l = B.length bs + {-# INLINE next #-} + next i + | i >= l = Done + | U8.validate1 x1 = Yield (unsafeChr8 x1) (i+1) + | i+1 < l && U8.validate2 x1 x2 = Yield (U8.chr2 x1 x2) (i+2) + | i+2 < l && U8.validate3 x1 x2 x3 = Yield (U8.chr3 x1 x2 x3) (i+3) + | i+3 < l && U8.validate4 x1 x2 x3 x4 = Yield (U8.chr4 x1 x2 x3 x4) (i+4) + | otherwise = encodingError "UTF-8" + where + x1 = idx i + x2 = idx (i + 1) + x3 = idx (i + 2) + x4 = idx (i + 3) + idx = B.unsafeIndex bs +{-# INLINE [0] streamUtf8 #-} + +-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little +-- endian UTF-16 encoding. +streamUtf16LE :: ByteString -> Stream Char +streamUtf16LE bs = Stream next 0 l + where + l = B.length bs + {-# INLINE next #-} + next i + | i >= l = Done + | i+1 < l && U16.validate1 x1 = Yield (unsafeChr x1) (i+2) + | i+3 < l && U16.validate2 x1 x2 = Yield (U16.chr2 x1 x2) (i+4) + | otherwise = encodingError "UTF-16LE" + where + x1 = idx i + (idx (i + 1) `shiftL` 8) + x2 = idx (i + 2) + (idx (i + 3) `shiftL` 8) + idx = fromIntegral . B.unsafeIndex bs :: Int -> Word16 +{-# INLINE [0] streamUtf16LE #-} + +-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big +-- endian UTF-16 encoding. +streamUtf16BE :: ByteString -> Stream Char +streamUtf16BE bs = Stream next 0 l + where + l = B.length bs + {-# INLINE next #-} + next i + | i >= l = Done + | i+1 < l && U16.validate1 x1 = Yield (unsafeChr x1) (i+2) + | i+3 < l && U16.validate2 x1 x2 = Yield (U16.chr2 x1 x2) (i+4) + | otherwise = encodingError "UTF16-BE" + where + x1 = (idx i `shiftL` 8) + idx (i + 1) + x2 = (idx (i + 2) `shiftL` 8) + idx (i + 3) + idx = fromIntegral . B.unsafeIndex bs :: Int -> Word16 +{-# INLINE [0] streamUtf16BE #-} + +-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big +-- endian UTF-32 encoding. +streamUtf32BE :: ByteString -> Stream Char +streamUtf32BE bs = Stream next 0 l + where + l = B.length bs + {-# INLINE next #-} + next i + | i >= l = Done + | i+3 < l && U32.validate x = Yield (unsafeChr32 x) (i+4) + | otherwise = encodingError "UTF-32BE" + where + x = shiftL x1 24 + shiftL x2 16 + shiftL x3 8 + x4 + x1 = idx i + x2 = idx (i+1) + x3 = idx (i+2) + x4 = idx (i+3) + idx = fromIntegral . B.unsafeIndex bs :: Int -> Word32 +{-# INLINE [0] streamUtf32BE #-} + +-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little +-- endian UTF-32 encoding. +streamUtf32LE :: ByteString -> Stream Char +streamUtf32LE bs = Stream next 0 l + where + l = B.length bs + {-# INLINE next #-} + next i + | i >= l = Done + | i+3 < l && U32.validate x = Yield (unsafeChr32 x) (i+4) + | otherwise = encodingError "UTF-32LE" + where + x = shiftL x4 24 + shiftL x3 16 + shiftL x2 8 + x1 + x1 = idx i + x2 = idx $ i+1 + x3 = idx $ i+2 + x4 = idx $ i+3 + idx = fromIntegral . B.unsafeIndex 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 + where + loop !fp !n !off !s = case next s of + Done -> trimUp fp n off + Skip s' -> loop fp n off s' + Yield x s' + | n == off -> realloc fp n off s' x + | otherwise -> do + withForeignPtr fp $ \p -> pokeByteOff p off x + loop fp n (off+1) s' + {-# 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 + {-# NOINLINE trimUp #-} + trimUp fp _ off = return $! PS fp 0 off + copy0 :: ForeignPtr Word8 -> Int -> Int -> IO (ForeignPtr Word8) + copy0 !src !srcLen !destLen = assert (srcLen <= destLen) $ do + dest <- mallocByteString destLen + withForeignPtr src $ \src' -> + withForeignPtr dest $ \dest' -> + memcpy dest' src' (fromIntegral destLen) + return dest + +internalError :: String -> a +internalError func = + error $ "Data.Text.Encoding.Fusion." ++ func ++ ": internal error" + +encodingError :: String -> a +encodingError encoding = + error $ "Data.Text.Encoding.Fusion: Bad " ++ encoding ++ " stream" diff --git a/Data/Text/Encoding/Utf16.hs b/Data/Text/Encoding/Utf16.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Encoding/Utf16.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE MagicHash #-} + +-- | +-- Module : Data.Text.Encoding.Utf16 +-- 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 : GHC +-- +-- Basic UTF-16 validation and character manipulation. +module Data.Text.Encoding.Utf16 + ( + chr2 + , validate1 + , validate2 + ) where + +import GHC.Exts +import GHC.Word (Word16(..)) + +chr2 :: Word16 -> Word16 -> Char +chr2 (W16# a#) (W16# b#) = C# (chr# (upper# +# lower# +# 0x10000#)) + where + x# = word2Int# a# + y# = word2Int# b# + upper# = uncheckedIShiftL# (x# -# 0xD800#) 10# + lower# = y# -# 0xDC00# +{-# INLINE chr2 #-} + +validate1 :: Word16 -> Bool +validate1 x1 = (x1 >= 0 && x1 < 0xD800) || x1 > 0xDFFF +{-# INLINE validate1 #-} + +validate2 :: Word16 -> Word16 -> Bool +validate2 x1 x2 = x1 >= 0xD800 && x1 <= 0xDBFF && + x2 >= 0xDC00 && x2 <= 0xDFFF +{-# INLINE validate2 #-} diff --git a/Data/Text/Encoding/Utf32.hs b/Data/Text/Encoding/Utf32.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Encoding/Utf32.hs @@ -0,0 +1,23 @@ +-- | +-- Module : Data.Text.Encoding.Utf16 +-- 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 +-- +-- Basic UTF-32 validation. +module Data.Text.Encoding.Utf32 + ( + validate + ) where + +import Data.Word (Word32) + +validate :: Word32 -> Bool +validate x1 = (x1 >= 0x0 && x1 < 0xD800) || (x1 > 0xDFFF && x1 <= 0x10FFFF) +{-# INLINE validate #-} diff --git a/Data/Text/Encoding/Utf8.hs b/Data/Text/Encoding/Utf8.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Encoding/Utf8.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE MagicHash #-} + +-- | +-- Module : Data.Text.Encoding.Utf16 +-- 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 : GHC +-- +-- Basic UTF-8 validation and character manipulation. +module Data.Text.Encoding.Utf8 + ( + -- Decomposition + ord2 + , ord3 + , ord4 + -- Construction + , chr2 + , chr3 + , chr4 + -- * Validation + , validate1 + , validate2 + , validate3 + , validate4 + ) where + +import Control.Exception (assert) +import Data.Char (ord) +import Data.Bits (shiftR, (.&.)) +import GHC.Exts +import GHC.Word (Word8(..)) + +default(Int) + +between :: Word8 -- ^ byte to check + -> Word8 -- ^ lower bound + -> Word8 -- ^ upper bound + -> Bool +between x y z = x >= y && x <= z +{-# INLINE between #-} + +ord2 :: Char -> (Word8,Word8) +ord2 c = assert (n >= 0x80 && n <= 0x07ff) (x1,x2) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 6) + 0xC0 + x2 = fromIntegral $ (n .&. 0x3F) + 0x80 + +ord3 :: Char -> (Word8,Word8,Word8) +ord3 c = assert (n >= 0x0800 && n <= 0xffff) (x1,x2,x3) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 12) + 0xE0 + x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + x3 = fromIntegral $ (n .&. 0x3F) + 0x80 + +ord4 :: Char -> (Word8,Word8,Word8,Word8) +ord4 c = assert (n >= 0x10000) (x1,x2,x3,x4) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 18) + 0xF0 + x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80 + x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + x4 = fromIntegral $ (n .&. 0x3F) + 0x80 + +chr2 :: Word8 -> Word8 -> Char +chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#)) + where + y1# = word2Int# x1# + y2# = word2Int# x2# + z1# = uncheckedIShiftL# (y1# -# 0xC0#) 6# + z2# = y2# -# 0x80# +{-# INLINE chr2 #-} + +chr3 :: Word8 -> Word8 -> Word8 -> Char +chr3 (W8# x1#) (W8# x2#) (W8# x3#) = C# (chr# (z1# +# z2# +# z3#)) + where + y1# = word2Int# x1# + y2# = word2Int# x2# + y3# = word2Int# x3# + z1# = uncheckedIShiftL# (y1# -# 0xE0#) 12# + z2# = uncheckedIShiftL# (y2# -# 0x80#) 6# + z3# = y3# -# 0x80# +{-# INLINE chr3 #-} + +chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char +chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) = + C# (chr# (z1# +# z2# +# z3# +# z4#)) + where + y1# = word2Int# x1# + y2# = word2Int# x2# + y3# = word2Int# x3# + y4# = word2Int# x4# + z1# = uncheckedIShiftL# (y1# -# 0xF0#) 18# + z2# = uncheckedIShiftL# (y2# -# 0x80#) 12# + z3# = uncheckedIShiftL# (y3# -# 0x80#) 6# + z4# = y4# -# 0x80# +{-# INLINE chr4 #-} + +validate1 :: Word8 -> Bool +validate1 x1 = between x1 0x00 0x7F +{-# INLINE validate1 #-} + +validate2 :: Word8 -> Word8 -> Bool +validate2 x1 x2 = between x1 0xC2 0xDF && between x2 0x80 0xBF +{-# INLINE validate2 #-} + +validate3 :: Word8 -> Word8 -> Word8 -> Bool +{-# INLINE validate3 #-} +validate3 x1 x2 x3 = validate3_1 || + validate3_2 || + validate3_3 || + validate3_4 + where + validate3_1 = (x1 == 0xE0) && + between x2 0xA0 0xBF && + between x3 0x80 0xBF + validate3_2 = between x1 0xE1 0xEC && + between x2 0x80 0xBF && + between x3 0x80 0xBF + validate3_3 = x1 == 0xED && + between x2 0x80 0x9F && + between x3 0x80 0xBF + validate3_4 = between x1 0xEE 0xEF && + between x2 0x80 0xBF && + between x3 0x80 0xBF + +validate4 :: Word8 -> Word8 -> Word8 -> Word8 -> Bool +{-# INLINE validate4 #-} +validate4 x1 x2 x3 x4 = validate4_1 || + validate4_2 || + validate4_3 + where + validate4_1 = x1 == 0xF0 && + between x2 0x90 0xBF && + between x3 0x80 0xBF && + between x4 0x80 0xBF + validate4_2 = between x1 0xF1 0xF3 && + between x2 0x80 0xBF && + between x3 0x80 0xBF && + between x4 0x80 0xBF + validate4_3 = x1 == 0xF4 && + between x2 0x80 0x8F && + between x3 0x80 0xBF && + between x4 0x80 0xBF diff --git a/Data/Text/Foreign.hs b/Data/Text/Foreign.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Foreign.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Data.Text.Foreign +-- Copyright : (c) Bryan O'Sullivan 2009 +-- +-- License : BSD-style +-- Maintainer : rtharper@aftereternity.co.uk, bos@serpentine.com, +-- duncan@haskell.org +-- Stability : experimental +-- Portability : GHC +-- +-- Support for using 'Text' data with native code via the Haskell +-- foreign function interface. + +module Data.Text.Foreign + ( + -- * Interoperability with native code + -- $interop + + -- * Safe conversion functions + fromPtr + , useAsPtr + -- * Unsafe conversion code + , lengthWord16 + , unsafeCopyToPtr + ) where + +import Control.Exception (assert) +import Control.Monad.ST (unsafeIOToST) +import Data.Text.Internal (Text(..), empty) +import qualified Data.Text.Array as A +import Data.Word (Word16) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (peek, poke) + +-- $interop +-- +-- The 'Text' type is implemented using arrays that are not guaranteed +-- to have a fixed address in the Haskell heap. All communication with +-- native code must thus occur by copying data back and forth. +-- +-- The 'Text' type's internal representation is UTF-16, using the +-- platform's native endianness. This makes copied data suitable for +-- use with native libraries that use a similar representation, such +-- as ICU. To interoperate with native libraries that use different +-- internal representations, such as UTF-8 or UTF-32, consider using +-- the functions in the 'Data.Text.Encoding' module. + +-- | /O(n)/ Create a new 'Text' from a 'Ptr' 'Word16' by copying the +-- contents of the array. +fromPtr :: Ptr Word16 -- ^ source array + -> Int -- ^ length of source array (in 'Word16' units) + -> IO Text +fromPtr _ 0 = return empty +fromPtr ptr len = assert (len > 0) $ return (Text arr 0 len) + where + arr = A.run (A.unsafeNew len >>= copy) + copy marr = loop ptr 0 + where + loop !p !i | i == len = return marr + | otherwise = do + A.unsafeWrite marr i =<< unsafeIOToST (peek p) + loop (p `plusPtr` 2) (i + 1) + +-- | /O(1)/ Return the length of a 'Text' in units of 'Word16'. This +-- is useful for sizing a target array appropriately before using +-- 'unsafeCopyToPtr'. +lengthWord16 :: Text -> Int +lengthWord16 (Text _arr _off len) = len + +-- | /O(n)/ Copy a 'Text' to an array. The array is assumed to be big +-- enough to hold the contents of the entire 'Text'. +unsafeCopyToPtr :: Text -> Ptr Word16 -> IO () +unsafeCopyToPtr (Text arr off len) ptr = loop ptr off + where + end = off + len + loop !p !i | i == end = return () + | otherwise = do + poke p (A.unsafeIndex arr i) + loop (p `plusPtr` 2) (i + 1) + +-- | /O(n)/ Perform an action on a temporary, mutable copy of a +-- 'Text'. The copy is freed as soon as the action returns. +useAsPtr :: Text -> (Ptr Word16 -> Int -> IO a) -> IO a +useAsPtr t@(Text _arr _off len) action = + allocaBytes (len * 2) $ \buf -> do + unsafeCopyToPtr t buf + action (castPtr buf) len diff --git a/Data/Text/Fusion.hs b/Data/Text/Fusion.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Fusion.hs @@ -0,0 +1,923 @@ +{-# LANGUAGE ExistentialQuantification, BangPatterns, MagicHash #-} + +-- | +-- Module : Data.Text.Fusion +-- 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 : GHC +-- +-- Text manipulation functions represented as fusible operations over +-- streams. +module Data.Text.Fusion + ( + -- * Types + Stream(..) + , Step(..) + + -- * Creation and elimination + , 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 + , findIndexOrEnd + , elemIndex + , elemIndices + , count + + -- * Zipping and unzipping + , zipWith + ) where + +import Prelude (Bool(..), Char, Either(..), Eq(..), Maybe(..), Monad(..), + Num(..), Ord(..), String, ($), (++), (.), (&&), + 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 qualified Data.Text.Array as A +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 + where + end = off+len + {-# INLINE next #-} + next !i + | i >= end = Done + | n >= 0xD800 && n <= 0xDBFF = Yield (U16.chr2 n n2) (i + 2) + | otherwise = Yield (unsafeChr n) (i + 1) + where + n = A.unsafeIndex arr i + n2 = A.unsafeIndex arr (i + 1) +{-# INLINE [0] stream #-} + +-- | /O(n)/ Convert a 'Text' into a 'Stream Char', but iterate +-- backwards. +reverseStream :: Text -> Stream Char +reverseStream (Text arr off len) = Stream next (off+len-1) len + where + {-# INLINE next #-} + next !i + | i < off = Done + | n >= 0xDC00 && n <= 0xDFFF = Yield (U16.chr2 n2 n) (i - 2) + | otherwise = Yield (unsafeChr n) (i - 1) + where + n = A.unsafeIndex arr i + n2 = A.unsafeIndex arr (i - 1) +{-# INLINE [0] reverseStream #-} + +-- | /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) + where + a = runST (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) + _ -> 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) + 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' +{-# 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' + where + len0' = max len0 4 + (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)) + where j = i + 1 + Skip s1 -> loop s1 i len marr + Yield x s1 | i < least -> do + let newLen = len * 2 + marr' <- A.unsafeNew newLen + A.unsafeCopy marr 0 marr' (newLen-len) len + write s1 (len+i) newLen marr' + | otherwise -> write s1 i len marr + where n = ord x + least | n < 0x10000 = 0 + | otherwise = 1 + m = n - 0x10000 + lo = fromIntegral $ (m `shiftR` 10) + 0xD800 + hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00 + write s i len marr + | n < 0x10000 = do + A.unsafeWrite marr i (fromIntegral n) + loop s (i-1) len marr + | otherwise = do + A.unsafeWrite marr (i-1) lo + A.unsafeWrite marr i hi + loop s (i-2) len marr +{-# 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) + 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 x z + in Yield x' (S2 :!: x' :!: s') + Skip s' -> Skip (S2 :!: z :!: s') + 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 + #-} + +------------------------------------------------------------------------------- +-- ** Indexing streams + +-- | /O(1)/ 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' +{-# 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 +{-# 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' +{-# INLINE [0] findIndices #-} + +-- | The 'findIndexOrEnd' function takes a predicate and a stream and +-- returns the index of the first element in the stream +-- satisfying the predicate. +findIndexOrEnd :: (Char -> Bool) -> Stream Char -> Int +findIndexOrEnd p (Stream next s0 _len) = loop_findIndex 0 s0 + where + loop_findIndex !i !s = case next s of + Done -> i + Skip s' -> loop_findIndex i s' -- hmm. not caught by QC + Yield x s' | p x -> i + | otherwise -> loop_findIndex (i+1) s' +{-# INLINE [0] findIndexOrEnd #-} + +-- | /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 Int +elemIndex a s = case elemIndices a s of + (i:_) -> Just i + _ -> Nothing +{-# 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' +{-# 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' +{-# 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/Internal.hs b/Data/Text/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | +-- Module : Data.Text +-- 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 : GHC +-- +-- Semi-public internals. Most users should not need to use this +-- module. + +module Data.Text.Internal + ( + -- * Types + Text(..) + -- * Construction + , text + -- * Code that must be here for accessibility + , empty + -- * Debugging + , showText + ) where + +import Control.Exception (assert) +import qualified Data.Text.Array as A +import Data.Typeable (Typeable) +import Data.Word (Word16) + +-- | A space efficient, packed, unboxed Unicode text type. +data Text = Text + {-# UNPACK #-} !(A.Array Word16) -- payload + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- length + deriving (Typeable) + +-- | Smart constructor. +text :: A.Array Word16 -> Int -> Int -> Text +text arr off len = + assert (len >= 0) . + assert (off >= 0) . + assert (alen == 0 || off < alen) . + assert (len == 0 || c < 0xDC00 || c > 0xDFFF) $ + Text arr off len + where c = A.unsafeIndex arr off + alen = A.length arr +{-# INLINE text #-} + +-- | /O(1)/ The empty 'Text'. +empty :: Text +empty = Text A.empty 0 0 +{-# INLINE [1] empty #-} + +-- | A useful 'show'-like function for debugging purposes. +showText :: Text -> String +showText (Text arr off len) = + "Text " ++ (show . take (off+len) . A.toList) arr ++ ' ' : + show off ++ ' ' : show len diff --git a/Data/Text/Unsafe.hs b/Data/Text/Unsafe.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Unsafe.hs @@ -0,0 +1,78 @@ +-- | +-- Module : Data.Text.Unsafe +-- Copyright : (c) Bryan O'Sullivan 2009 +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : portable +-- +-- A module containing unsafe 'Text' operations, for very very careful +-- use in heavily tested code. +module Data.Text.Unsafe + ( + iter + , iter_ + , reverseIter + , unsafeHead + , unsafeTail + ) where + +import Control.Exception (assert) +import Data.Text.Internal (Text(..)) +import Data.Text.UnsafeChar (unsafeChr) +import Data.Text.Encoding.Utf16 (chr2) +import qualified Data.Text.Array as A + +-- | /O(1)/ A variant of 'head' for non-empty 'Text'. 'unsafeHead' +-- omits the check for the empty case, so there is an obligation on +-- the programmer to provide a proof that the 'Text' is non-empty. +unsafeHead :: Text -> Char +unsafeHead (Text arr off len) + | m < 0xD800 || m > 0xDBFF = unsafeChr m + | otherwise = chr2 m n + where m = assert (len > 0) $ A.unsafeIndex arr off + n = assert (len > 1) $ A.unsafeIndex arr (off+1) +{-# INLINE unsafeHead #-} + +-- | /O(1)/ A variant of 'tail' for non-empty 'Text'. 'unsafeHead' +-- omits the check for the empty case, so there is an obligation on +-- the programmer to provide a proof that the 'Text' is non-empty. +unsafeTail :: Text -> Text +unsafeTail t@(Text arr off len) = + assert (d <= len) $ Text arr (off+d) (len-d) + where d = iter_ t 0 +{-# INLINE unsafeTail #-} + +-- | /O(1)/ Iterate one step forwards through a UTF-16 array, +-- returning the current character and the delta to add to give the +-- next offset to iterate at. +iter :: Text -> Int -> (Char,Int) +iter (Text arr off len) i + | m < 0xD800 || m > 0xDBFF = (unsafeChr m, 1) + | otherwise = (chr2 m n, 2) + where m = assert (i < len) $ A.unsafeIndex arr j + n = assert (i + 1 < len) $ A.unsafeIndex arr k + j = assert (i >= 0) $ off + i + k = j + 1 +{-# INLINE iter #-} + +-- | /O(1)/ Iterate one step through a UTF-16 array, returning the +-- delta to add to give the next offset to iterate at. +iter_ :: Text -> Int -> Int +iter_ (Text arr off len) i | m < 0xD800 || m > 0xDBFF = 1 + | otherwise = 2 + where m = assert (i >= 0 && i < len) $ A.unsafeIndex arr (off+i) +{-# INLINE iter_ #-} + +-- | /O(1)/ Iterate one step backwards through a UTF-16 array, +-- returning the current character and the delta to add (i.e. a +-- negative number) to give the next offset to iterate at. +reverseIter :: Text -> Int -> (Char,Int) +reverseIter (Text arr off len) i + | m < 0xDC00 || m > 0xDFFF = (unsafeChr m, -1) + | otherwise = (chr2 n m, -2) + where m = assert (i < len) $ A.unsafeIndex arr j + n = assert (i - 1 >= 0) $ A.unsafeIndex arr k + j = assert (i >= 0) $ off + i + k = j - 1 +{-# INLINE reverseIter #-} diff --git a/Data/Text/UnsafeChar.hs b/Data/Text/UnsafeChar.hs new file mode 100644 --- /dev/null +++ b/Data/Text/UnsafeChar.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE MagicHash #-} + +-- | +-- Module : Data.Text.UnsafeChar +-- 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 : GHC +-- +-- Fast character manipulation functions. +module Data.Text.UnsafeChar + ( + unsafeChr + , unsafeChr8 + , unsafeChr32 + , unsafeWrite + , unsafeWriteRev + ) where + +import Control.Exception (assert) +import Control.Monad.ST (ST) +import Data.Bits ((.&.), shiftR) +import Data.Char (ord) +import GHC.Exts (Char(..), chr#, word2Int#) +import GHC.Word (Word8(..), Word16(..), Word32(..)) +import qualified Data.Text.Array as A + +unsafeChr :: Word16 -> Char +unsafeChr (W16# w#) = C# (chr# (word2Int# w#)) +{-# INLINE unsafeChr #-} + +unsafeChr8 :: Word8 -> Char +unsafeChr8 (W8# w#) = C# (chr# (word2Int# w#)) +{-# INLINE unsafeChr8 #-} + +unsafeChr32 :: Word32 -> Char +unsafeChr32 (W32# w#) = C# (chr# (word2Int# w#)) +{-# INLINE unsafeChr32 #-} + +unsafeWrite :: A.MArray s Word16 -> Int -> Char -> ST s Int +unsafeWrite marr i c + | n < 0x10000 = do + assert (i >= 0) . assert (i < A.length marr) $ + A.unsafeWrite marr i (fromIntegral n) + return (i+1) + | otherwise = do + assert (i >= 0) . assert (i < A.length marr - 1) $ + A.unsafeWrite marr i lo + A.unsafeWrite marr (i+1) hi + return (i+2) + where n = ord c + m = n - 0x10000 + lo = fromIntegral $ (m `shiftR` 10) + 0xD800 + hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00 +{-# INLINE unsafeWrite #-} + +unsafeWriteRev :: A.MArray s Word16 -> Int -> Char -> ST s Int +unsafeWriteRev marr i c + | n < 0x10000 = do + assert (i >= 0) . assert (i < A.length marr) $ + A.unsafeWrite marr i (fromIntegral n) + return (i-1) + | otherwise = do + assert (i >= 1) . assert (i < A.length marr) $ + A.unsafeWrite marr (i-1) lo + A.unsafeWrite marr i hi + return (i-2) + where n = ord c + m = n - 0x10000 + lo = fromIntegral $ (m `shiftR` 10) + 0xD800 + hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00 +{-# INLINE unsafeWriteRev #-} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2008-2009, Tom Harper +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,35 @@ +Text: Fast, packed Unicode strings, using stream fusion +------------------------------------------------------- + +This package provides the Data.Text library, a library for the space- +and time-efficient manipulation of Unicode text in Haskell. + + +Normalization, conversion, and collation, oh my! +------------------------------------------------ + +This library intentionally provides a simple API based on the Haskell +prelude's list manipulation functions. For more complicated +real-world tasks, such as Unicode normalization, conversion to and +from a larger variety of encodings, and collation, use the text-icu +package: + + http://hackage.haskell.org/cgi-bin/hackage-scripts/package/text-icu + +That library uses the well-respected and liberally licensed ICU +library to provide these facilities. + + +Source code +----------- + +darcs get http://code.haskell.org/text + + +Authors +------- + +The base code for this library was originally written by Tom Harper, +based on the stream fusion framework developed by Roman Leshchinskiy, +Duncan Coutts, and Don Stewart. The core library was fleshed out, +debugged, and tested by Bryan O'Sullivan. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/text.cabal b/text.cabal new file mode 100644 --- /dev/null +++ b/text.cabal @@ -0,0 +1,45 @@ +name: text +version: 0.1 +synopsis: An efficient packed Unicode text type +description: An efficient packed Unicode text type. +license: BSD3 +license-file: LICENSE +author: Tom Harper +maintainer: Bryan O'Sullivan + Tom Harper + Duncan Coutts +copyright: 2008-2009 Tom Harper +category: Data, Text +build-type: Simple +cabal-version: >= 1.2 +extra-source-files: README + +library + exposed-modules: + Data.Text + Data.Text.Encoding + Data.Text.Encoding.Fusion + Data.Text.Foreign + Data.Text.Fusion + other-modules: + Data.Text.Array + Data.Text.Internal + Data.Text.Unsafe + Data.Text.UnsafeChar + Data.Text.Encoding.Utf8 + Data.Text.Encoding.Utf16 + Data.Text.Encoding.Utf32 + + build-depends: + base < 5, + bytestring >= 0.9 && < 1.0 + if impl(ghc >= 6.10) + build-depends: + ghc-prim, base >= 4 + + -- gather extensive profiling data for now + ghc-prof-options: -auto-all + + ghc-options: -Wall -funbox-strict-fields -O2 + if impl(ghc >= 6.8) + ghc-options: -fwarn-tabs