diff --git a/Data/Text.hs b/Data/Text.hs --- a/Data/Text.hs +++ b/Data/Text.hs @@ -11,8 +11,7 @@ -- (c) 2008, 2009 Tom Harper -- -- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org +-- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- @@ -208,18 +207,18 @@ import qualified Data.List as L import Data.Monoid (Monoid(..)) import Data.String (IsString(..)) -import qualified Data.Text.Fusion as S -import qualified Data.Text.Fusion.Common as S -import Data.Text.Fusion (stream, reverseStream, unstream) -import Data.Text.Private (span_) +import qualified Data.Text.Internal.Fusion as S +import qualified Data.Text.Internal.Fusion.Common as S +import Data.Text.Internal.Fusion (stream, reverseStream, unstream) +import Data.Text.Internal.Private (span_) import Data.Text.Internal (Text(..), empty, firstf, safe, text, textP) import qualified Prelude as P import Data.Text.Unsafe (Iter(..), iter, iter_, lengthWord16, reverseIter, unsafeHead, unsafeTail) -import Data.Text.UnsafeChar (unsafeChr) -import qualified Data.Text.Util as U -import qualified Data.Text.Encoding.Utf16 as U16 -import Data.Text.Search (indices) +import Data.Text.Internal.Unsafe.Char (unsafeChr) +import qualified Data.Text.Internal.Functions as F +import qualified Data.Text.Internal.Encoding.Utf16 as U16 +import Data.Text.Internal.Search (indices) #if defined(__HADDOCK__) import Data.ByteString (ByteString) import qualified Data.Text.Lazy as L @@ -372,7 +371,7 @@ pack = unstream . S.map safe . S.streamList {-# INLINE [1] pack #-} --- | /O(n)/ Convert a Text into a String. Subject to fusion. +-- | /O(n)/ Convert a 'Text' into a 'String'. Subject to fusion. unpack :: Text -> String unpack = S.unstreamList . stream {-# INLINE [1] unpack #-} @@ -597,7 +596,7 @@ -- 'Text's and concatenates the list after interspersing the first -- argument between each element of the list. intercalate :: Text -> [Text] -> Text -intercalate t = concat . (U.intersperse t) +intercalate t = concat . (F.intersperse t) {-# INLINE intercalate #-} -- | /O(n)/ The 'intersperse' function takes a character and places it diff --git a/Data/Text/Array.hs b/Data/Text/Array.hs --- a/Data/Text/Array.hs +++ b/Data/Text/Array.hs @@ -6,8 +6,7 @@ -- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan -- -- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org +-- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- @@ -66,8 +65,8 @@ import Control.Monad.ST (unsafeIOToST) #endif import Data.Bits ((.&.), xor) -import Data.Text.Unsafe.Base (inlinePerformIO) -import Data.Text.UnsafeShift (shiftL, shiftR) +import Data.Text.Internal.Unsafe (inlinePerformIO) +import Data.Text.Internal.Unsafe.Shift (shiftL, shiftR) #if __GLASGOW_HASKELL__ >= 703 import Foreign.C.Types (CInt(CInt), CSize(CSize)) #else diff --git a/Data/Text/Encoding.hs b/Data/Text/Encoding.hs --- a/Data/Text/Encoding.hs +++ b/Data/Text/Encoding.hs @@ -10,8 +10,7 @@ -- (c) 2008, 2009 Tom Harper -- -- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org +-- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- @@ -55,36 +54,54 @@ , encodeUtf16BE , encodeUtf32LE , encodeUtf32BE + +#if MIN_VERSION_bytestring(0,10,4) + -- * Encoding Text using ByteString Builders + -- | /Note/ that these functions are only available if built against + -- @bytestring >= 0.10.4.0@. + , encodeUtf8Builder + , encodeUtf8BuilderEscaped +#endif ) where -import Control.Exception (evaluate, try) #if __GLASGOW_HASKELL__ >= 702 import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO) #else import Control.Monad.ST (unsafeIOToST, unsafeSTToIO) #endif -import Control.Monad.ST (runST) + +#if MIN_VERSION_bytestring(0,10,4) import Data.Bits ((.&.)) +import Data.Text.Internal.Unsafe.Char (ord) +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Extra as B +import qualified Data.ByteString.Builder.Internal as B hiding (empty) +import qualified Data.ByteString.Builder.Prim as BP +import qualified Data.ByteString.Builder.Prim.Internal as BP +import qualified Data.Text.Internal.Encoding.Utf16 as U16 +#endif + +import Control.Exception (evaluate, try) +import Control.Monad.ST (runST) import Data.ByteString as B -import Data.ByteString.Internal as B +import Data.ByteString.Internal as B hiding (c2w) import Data.Text () import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode) import Data.Text.Internal (Text(..), safe, textP) -import Data.Text.Private (runText) -import Data.Text.UnsafeChar (ord, unsafeWrite) -import Data.Text.UnsafeShift (shiftL, shiftR) +import Data.Text.Internal.Private (runText) +import Data.Text.Internal.Unsafe.Char (unsafeWrite) +import Data.Text.Internal.Unsafe.Shift (shiftR) +import Data.Text.Unsafe (unsafeDupablePerformIO) import Data.Word (Word8, Word32) -import Foreign.C.Types (CSize) +import Foreign.C.Types (CSize(..)) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Marshal.Utils (with) import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr) import Foreign.Storable (Storable, peek, poke) -import GHC.Base (MutableByteArray#) +import GHC.Base (ByteArray#, MutableByteArray#) import qualified Data.Text.Array as A -import qualified Data.Text.Encoding.Fusion as E -import qualified Data.Text.Encoding.Utf16 as U16 -import qualified Data.Text.Fusion as F -import Data.Text.Unsafe (unsafeDupablePerformIO) +import qualified Data.Text.Internal.Encoding.Fusion as E +import qualified Data.Text.Internal.Fusion as F #include "text_cbits.h" @@ -146,7 +163,7 @@ loop (ptr `plusPtr` off) (unsafeIOToST . go) =<< A.new len where - desc = "Data.Text.Encoding.decodeUtf8: Invalid UTF-8 stream" + desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" {- INLINE[0] decodeUtf8With #-} -- $stream @@ -267,7 +284,7 @@ return $ Some chunkText (B.drop left bs) (decodeChunk codepoint state) in loop (ptr `plusPtr` off) - desc = "Data.Text.Encoding.streamDecodeUtf8With: Invalid UTF-8 stream" + desc = "Data.Text.Internal.Encoding.streamDecodeUtf8With: Invalid UTF-8 stream" -- | Decode a 'ByteString' containing UTF-8 encoded text that is known -- to be valid. @@ -290,61 +307,88 @@ decodeUtf8' = unsafeDupablePerformIO . try . evaluate . decodeUtf8With strictDecode {-# INLINE decodeUtf8' #-} +#if MIN_VERSION_bytestring(0,10,4) + +-- | Encode text to a ByteString 'B.Builder' using UTF-8 encoding. +encodeUtf8Builder :: Text -> B.Builder +encodeUtf8Builder = encodeUtf8BuilderEscaped (BP.liftFixedToBounded BP.word8) + +-- | Encode text using UTF-8 encoding and escape the ASCII characters using +-- a 'BP.BoundedPrim'. +-- +-- Use this function is to implement efficient encoders for text-based formats +-- like JSON or HTML. +{-# INLINE encodeUtf8BuilderEscaped #-} +-- TODO: Extend documentation with references to source code in @blaze-html@ +-- or @aeson@ that uses this function. +encodeUtf8BuilderEscaped :: BP.BoundedPrim Word8 -> Text -> B.Builder +encodeUtf8BuilderEscaped be = + -- manual eta-expansion to ensure inlining works as expected + \txt -> B.builder (mkBuildstep txt) + where + bound = max 4 $ BP.sizeBound be + + mkBuildstep (Text arr off len) !k = + outerLoop off + where + iend = off + len + + outerLoop !i0 !br@(B.BufferRange op0 ope) + | i0 >= iend = k br + | outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining) + -- TODO: Use a loop with an integrated bound's check if outRemaining + -- is smaller than 8, as this will save on divisions. + | otherwise = return $ B.bufferFull bound op0 (outerLoop i0) + where + outRemaining = (ope `minusPtr` op0) `div` bound + inpRemaining = iend - i0 + + goPartial !iendTmp = go i0 op0 + where + go !i !op + | i < iendTmp = case A.unsafeIndex arr i of + w | w <= 0x7F -> do + BP.runB be (fromIntegral w) op >>= go (i + 1) + | w <= 0x7FF -> do + poke8 0 $ (w `shiftR` 6) + 0xC0 + poke8 1 $ (w .&. 0x3f) + 0x80 + go (i + 1) (op `plusPtr` 2) + | 0xD800 <= w && w <= 0xDBFF -> do + let c = ord $ U16.chr2 w (A.unsafeIndex arr (i+1)) + poke8 0 $ (c `shiftR` 18) + 0xF0 + poke8 1 $ ((c `shiftR` 12) .&. 0x3F) + 0x80 + poke8 2 $ ((c `shiftR` 6) .&. 0x3F) + 0x80 + poke8 3 $ (c .&. 0x3F) + 0x80 + go (i + 2) (op `plusPtr` 4) + | otherwise -> do + poke8 0 $ (w `shiftR` 12) + 0xE0 + poke8 1 $ ((w `shiftR` 6) .&. 0x3F) + 0x80 + poke8 2 $ (w .&. 0x3F) + 0x80 + go (i + 1) (op `plusPtr` 3) + | otherwise = + outerLoop i (B.BufferRange op ope) + where + poke8 j v = poke (op `plusPtr` j) (fromIntegral v :: Word8) +#endif + -- | Encode text using UTF-8 encoding. encodeUtf8 :: Text -> ByteString -encodeUtf8 (Text arr off len) = unsafeDupablePerformIO $ do - let size0 = max len 4 - mallocByteString size0 >>= start size0 off 0 - where - start size n0 m0 fp = withForeignPtr fp $ loop n0 m0 - where - loop n1 m1 ptr = go n1 m1 - where - offLen = off + len - go !n !m - | n == offLen = return (PS fp 0 m) - | otherwise = do - let poke8 k v = poke (ptr `plusPtr` k) (fromIntegral v :: Word8) - ensure k act - | size-m >= k = act - | otherwise = {-# SCC "resizeUtf8/ensure" #-} do - let newSize = size `shiftL` 1 - fp' <- mallocByteString newSize - withForeignPtr fp' $ \ptr' -> - memcpy ptr' ptr (fromIntegral m) - start newSize n m fp' - {-# INLINE ensure #-} - case A.unsafeIndex arr n of - w| w <= 0x7F -> ensure 1 $ do - poke (ptr `plusPtr` m) (fromIntegral w :: Word8) - -- A single ASCII octet is likely to start a run of - -- them. We see better performance when we - -- special-case this assumption. - let end = ptr `plusPtr` size - ascii !t !u - | t == offLen || u == end || v >= 0x80 = - go t (u `minusPtr` ptr) - | otherwise = do - poke u (fromIntegral v :: Word8) - ascii (t+1) (u `plusPtr` 1) - where v = A.unsafeIndex arr t - ascii (n+1) (ptr `plusPtr` (m+1)) - | w <= 0x7FF -> ensure 2 $ do - poke8 m $ (w `shiftR` 6) + 0xC0 - poke8 (m+1) $ (w .&. 0x3f) + 0x80 - go (n+1) (m+2) - | 0xD800 <= w && w <= 0xDBFF -> ensure 4 $ do - let c = ord $ U16.chr2 w (A.unsafeIndex arr (n+1)) - poke8 m $ (c `shiftR` 18) + 0xF0 - poke8 (m+1) $ ((c `shiftR` 12) .&. 0x3F) + 0x80 - poke8 (m+2) $ ((c `shiftR` 6) .&. 0x3F) + 0x80 - poke8 (m+3) $ (c .&. 0x3F) + 0x80 - go (n+2) (m+4) - | otherwise -> ensure 3 $ do - poke8 m $ (w `shiftR` 12) + 0xE0 - poke8 (m+1) $ ((w `shiftR` 6) .&. 0x3F) + 0x80 - poke8 (m+2) $ (w .&. 0x3F) + 0x80 - go (n+1) (m+3) +encodeUtf8 (Text arr off len) + | len == 0 = B.empty + | otherwise = unsafeDupablePerformIO $ do + fp <- mallocByteString (len*4) + withForeignPtr fp $ \ptr -> + with ptr $ \destPtr -> do + c_encode_utf8 destPtr (A.aBA arr) (fromIntegral off) (fromIntegral len) + newDest <- peek destPtr + let utf8len = newDest `minusPtr` ptr + if utf8len >= len `shiftR` 1 + then return (PS fp 0 utf8len) + else do + fp' <- mallocByteString utf8len + withForeignPtr fp' $ \ptr' -> do + memcpy ptr' ptr (fromIntegral utf8len) + return (PS fp' 0 utf8len) -- | Decode text from little endian UTF-16 encoding. decodeUtf16LEWith :: OnDecodeError -> ByteString -> Text @@ -433,3 +477,6 @@ foreign import ccall unsafe "_hs_text_decode_latin1" c_decode_latin1 :: MutableByteArray# s -> Ptr Word8 -> Ptr Word8 -> IO () + +foreign import ccall unsafe "_hs_text_encode_utf8" c_encode_utf8 + :: Ptr (Ptr Word8) -> ByteArray# -> CSize -> CSize -> IO () diff --git a/Data/Text/Encoding/Error.hs b/Data/Text/Encoding/Error.hs --- a/Data/Text/Encoding/Error.hs +++ b/Data/Text/Encoding/Error.hs @@ -7,8 +7,7 @@ -- Copyright : (c) Bryan O'Sullivan 2009 -- -- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org +-- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- diff --git a/Data/Text/Encoding/Fusion.hs b/Data/Text/Encoding/Fusion.hs deleted file mode 100644 --- a/Data/Text/Encoding/Fusion.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, Rank2Types #-} - --- | --- Module : Data.Text.Encoding.Fusion --- Copyright : (c) Tom Harper 2008-2009, --- (c) Bryan O'Sullivan 2009, --- (c) Duncan Coutts 2009 --- --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.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 - - , module Data.Text.Encoding.Fusion.Common - ) where - -#if defined(ASSERTS) -import Control.Exception (assert) -#endif -import Data.ByteString.Internal (ByteString(..), mallocByteString, memcpy) -import Data.Text.Fusion (Step(..), Stream(..)) -import Data.Text.Fusion.Size -import Data.Text.Encoding.Error -import Data.Text.Encoding.Fusion.Common -import Data.Text.UnsafeChar (unsafeChr, unsafeChr8, unsafeChr32) -import Data.Text.UnsafeShift (shiftL, shiftR) -import Data.Word (Word8, Word16, Word32) -import Foreign.ForeignPtr (withForeignPtr, ForeignPtr) -import Foreign.Storable (pokeByteOff) -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 -import Data.Text.Unsafe (unsafeDupablePerformIO) - -streamASCII :: ByteString -> Stream Char -streamASCII bs = Stream next 0 (maxSize 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 -{-# DEPRECATED streamASCII "Do not use this function" #-} -{-# INLINE [0] streamASCII #-} - --- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using UTF-8 --- encoding. -streamUtf8 :: OnDecodeError -> ByteString -> Stream Char -streamUtf8 onErr bs = Stream next 0 (maxSize l) - where - l = B.length bs - 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 = decodeError "streamUtf8" "UTF-8" onErr (Just x1) (i+1) - 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 :: OnDecodeError -> ByteString -> Stream Char -streamUtf16LE onErr bs = Stream next 0 (maxSize (l `shiftR` 1)) - 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 = decodeError "streamUtf16LE" "UTF-16LE" onErr Nothing (i+1) - 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 :: OnDecodeError -> ByteString -> Stream Char -streamUtf16BE onErr bs = Stream next 0 (maxSize (l `shiftR` 1)) - 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 = decodeError "streamUtf16BE" "UTF-16BE" onErr Nothing (i+1) - 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 :: OnDecodeError -> ByteString -> Stream Char -streamUtf32BE onErr bs = Stream next 0 (maxSize (l `shiftR` 2)) - where - l = B.length bs - {-# INLINE next #-} - next i - | i >= l = Done - | i+3 < l && U32.validate x = Yield (unsafeChr32 x) (i+4) - | otherwise = decodeError "streamUtf32BE" "UTF-32BE" onErr Nothing (i+1) - 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 :: OnDecodeError -> ByteString -> Stream Char -streamUtf32LE onErr bs = Stream next 0 (maxSize (l `shiftR` 2)) - where - l = B.length bs - {-# INLINE next #-} - next i - | i >= l = Done - | i+3 < l && U32.validate x = Yield (unsafeChr32 x) (i+4) - | otherwise = decodeError "streamUtf32LE" "UTF-32LE" onErr Nothing (i+1) - 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' 'Word8' to a 'ByteString'. -unstream :: Stream Word8 -> ByteString -unstream (Stream next s0 len) = unsafeDupablePerformIO $ do - let mlen = upperBound 4 len - mallocByteString mlen >>= loop mlen 0 s0 - where - loop !n !off !s fp = case next s of - Done -> trimUp fp n off - Skip s' -> loop n off s' fp - Yield x s' - | off == n -> realloc fp n off s' x - | otherwise -> do - withForeignPtr fp $ \p -> pokeByteOff p off x - loop n (off+1) s' fp - {-# NOINLINE realloc #-} - realloc fp n off s x = do - let n' = n+n - fp' <- copy0 fp n n' - withForeignPtr fp' $ \p -> pokeByteOff p off x - loop n' (off+1) s fp' - {-# NOINLINE trimUp #-} - trimUp fp _ off = return $! PS fp 0 off - copy0 :: ForeignPtr Word8 -> Int -> Int -> IO (ForeignPtr Word8) - copy0 !src !srcLen !destLen = -#if defined(ASSERTS) - assert (srcLen <= destLen) $ -#endif - do - dest <- mallocByteString destLen - withForeignPtr src $ \src' -> - withForeignPtr dest $ \dest' -> - memcpy dest' src' (fromIntegral srcLen) - return dest - -decodeError :: forall s. String -> String -> OnDecodeError -> Maybe Word8 - -> s -> Step s Char -decodeError func kind onErr mb i = - case onErr desc mb of - Nothing -> Skip i - Just c -> Yield c i - where desc = "Data.Text.Encoding.Fusion." ++ func ++ ": Invalid " ++ - kind ++ " stream" diff --git a/Data/Text/Encoding/Fusion/Common.hs b/Data/Text/Encoding/Fusion/Common.hs deleted file mode 100644 --- a/Data/Text/Encoding/Fusion/Common.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - --- | --- Module : Data.Text.Encoding.Fusion.Common --- Copyright : (c) Tom Harper 2008-2009, --- (c) Bryan O'Sullivan 2009, --- (c) Duncan Coutts 2009, --- (c) Jasper Van der Jeugt 2011 --- --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org --- Stability : experimental --- Portability : portable --- --- Fusible 'Stream'-oriented functions for converting between 'Text' --- and several common encodings. - -module Data.Text.Encoding.Fusion.Common - ( - -- * Restreaming - -- Restreaming is the act of converting from one 'Stream' - -- representation to another. - restreamUtf16LE - , restreamUtf16BE - , restreamUtf32LE - , restreamUtf32BE - ) where - -import Data.Bits ((.&.)) -import Data.Text.Fusion (Step(..), Stream(..)) -import Data.Text.Fusion.Internal (RS(..)) -import Data.Text.UnsafeChar (ord) -import Data.Text.UnsafeShift (shiftR) -import Data.Word (Word8) - -restreamUtf16BE :: Stream Char -> Stream Word8 -restreamUtf16BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2) - where - next (RS0 s) = case next0 s of - Done -> Done - Skip s' -> Skip (RS0 s') - Yield x s' - | n < 0x10000 -> Yield (fromIntegral $ n `shiftR` 8) $ - RS1 s' (fromIntegral n) - | otherwise -> Yield c1 $ RS3 s' c2 c3 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 (RS1 s x2) = Yield x2 (RS0 s) - next (RS2 s x2 x3) = Yield x2 (RS1 s x3) - next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4) - {-# INLINE next #-} -{-# INLINE restreamUtf16BE #-} - -restreamUtf16LE :: Stream Char -> Stream Word8 -restreamUtf16LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2) - where - next (RS0 s) = case next0 s of - Done -> Done - Skip s' -> Skip (RS0 s') - Yield x s' - | n < 0x10000 -> Yield (fromIntegral n) $ - RS1 s' (fromIntegral $ shiftR n 8) - | otherwise -> Yield c1 $ RS3 s' c2 c3 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 (RS1 s x2) = Yield x2 (RS0 s) - next (RS2 s x2 x3) = Yield x2 (RS1 s x3) - next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4) - {-# INLINE next #-} -{-# INLINE restreamUtf16LE #-} - -restreamUtf32BE :: Stream Char -> Stream Word8 -restreamUtf32BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2) - where - next (RS0 s) = case next0 s of - Done -> Done - Skip s' -> Skip (RS0 s') - Yield x s' -> Yield c1 (RS3 s' c2 c3 c4) - where - n = ord x - c1 = fromIntegral $ shiftR n 24 - c2 = fromIntegral $ shiftR n 16 - c3 = fromIntegral $ shiftR n 8 - c4 = fromIntegral n - next (RS1 s x2) = Yield x2 (RS0 s) - next (RS2 s x2 x3) = Yield x2 (RS1 s x3) - next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4) - {-# INLINE next #-} -{-# INLINE restreamUtf32BE #-} - -restreamUtf32LE :: Stream Char -> Stream Word8 -restreamUtf32LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2) - where - next (RS0 s) = case next0 s of - Done -> Done - Skip s' -> Skip (RS0 s') - Yield x s' -> Yield c1 (RS3 s' c2 c3 c4) - where - n = ord x - c4 = fromIntegral $ shiftR n 24 - c3 = fromIntegral $ shiftR n 16 - c2 = fromIntegral $ shiftR n 8 - c1 = fromIntegral n - next (RS1 s x2) = Yield x2 (RS0 s) - next (RS2 s x2 x3) = Yield x2 (RS1 s x3) - next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4) - {-# INLINE next #-} -{-# INLINE restreamUtf32LE #-} diff --git a/Data/Text/Encoding/Utf16.hs b/Data/Text/Encoding/Utf16.hs deleted file mode 100644 --- a/Data/Text/Encoding/Utf16.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE MagicHash, BangPatterns #-} - --- | --- Module : Data.Text.Encoding.Utf16 --- Copyright : (c) 2008, 2009 Tom Harper, --- (c) 2009 Bryan O'Sullivan, --- (c) 2009 Duncan Coutts --- --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- 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 < 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 deleted file mode 100644 --- a/Data/Text/Encoding/Utf32.hs +++ /dev/null @@ -1,23 +0,0 @@ --- | --- Module : Data.Text.Encoding.Utf32 --- Copyright : (c) 2008, 2009 Tom Harper, --- (c) 2009, 2010 Bryan O'Sullivan, --- (c) 2009 Duncan Coutts --- --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- 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 < 0xD800 || (x1 > 0xDFFF && x1 <= 0x10FFFF) -{-# INLINE validate #-} diff --git a/Data/Text/Encoding/Utf8.hs b/Data/Text/Encoding/Utf8.hs deleted file mode 100644 --- a/Data/Text/Encoding/Utf8.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, BangPatterns #-} - --- | --- Module : Data.Text.Encoding.Utf8 --- Copyright : (c) 2008, 2009 Tom Harper, --- (c) 2009, 2010 Bryan O'Sullivan, --- (c) 2009 Duncan Coutts --- --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- 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 - -#if defined(ASSERTS) -import Control.Exception (assert) -#endif -import Data.Bits ((.&.)) -import Data.Text.UnsafeChar (ord) -import Data.Text.UnsafeShift (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 = -#if defined(ASSERTS) - assert (n >= 0x80 && n <= 0x07ff) -#endif - (x1,x2) - where - n = ord c - x1 = fromIntegral $ (n `shiftR` 6) + 0xC0 - x2 = fromIntegral $ (n .&. 0x3F) + 0x80 - -ord3 :: Char -> (Word8,Word8,Word8) -ord3 c = -#if defined(ASSERTS) - assert (n >= 0x0800 && n <= 0xffff) -#endif - (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 = -#if defined(ASSERTS) - assert (n >= 0x10000) -#endif - (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 = x1 <= 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 --- a/Data/Text/Foreign.hs +++ b/Data/Text/Foreign.hs @@ -4,8 +4,7 @@ -- Copyright : (c) 2009, 2010 Bryan O'Sullivan -- -- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org +-- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- diff --git a/Data/Text/Fusion.hs b/Data/Text/Fusion.hs deleted file mode 100644 --- a/Data/Text/Fusion.hs +++ /dev/null @@ -1,231 +0,0 @@ -{-# LANGUAGE BangPatterns, MagicHash #-} - --- | --- Module : Data.Text.Fusion --- Copyright : (c) Tom Harper 2008-2009, --- (c) Bryan O'Sullivan 2009-2010, --- (c) Duncan Coutts 2009 --- --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.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 - - , length - - -- * Transformations - , reverse - - -- * Construction - -- ** Scans - , reverseScanr - - -- ** Accumulating maps - , mapAccumL - - -- ** Generation and unfolding - , unfoldrN - - -- * Indexing - , index - , findIndex - , countChar - ) where - -import Prelude (Bool(..), Char, Maybe(..), Monad(..), Int, - Num(..), Ord(..), ($), (&&), - fromIntegral, otherwise) -import Data.Bits ((.&.)) -import Data.Text.Internal (Text(..)) -import Data.Text.Private (runText) -import Data.Text.UnsafeChar (ord, unsafeChr, unsafeWrite) -import Data.Text.UnsafeShift (shiftL, shiftR) -import qualified Data.Text.Array as A -import qualified Data.Text.Fusion.Common as S -import Data.Text.Fusion.Internal -import Data.Text.Fusion.Size -import qualified Data.Text.Internal as I -import qualified Data.Text.Encoding.Utf16 as U16 - -default(Int) - --- | /O(n)/ Convert a 'Text' into a 'Stream Char'. -stream :: Text -> Stream Char -stream (Text arr off len) = Stream next off (maxSize len) - where - !end = off+len - 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) (maxSize 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) = runText $ \done -> do - let mlen = upperBound 4 len - arr0 <- A.new mlen - let outer arr top = loop - where - loop !s !i = - case next0 s of - Done -> done arr i - Skip s' -> loop s' i - Yield x s' - | j >= top -> {-# SCC "unstream/resize" #-} do - let top' = (top + 1) `shiftL` 1 - arr' <- A.new top' - A.copyM arr' 0 arr 0 top - outer arr' top' s i - | otherwise -> do d <- unsafeWrite arr i x - loop s' (i+d) - where j | ord x < 0x10000 = i - | otherwise = i + 1 - outer arr0 mlen s0 0 -{-# INLINE [0] unstream #-} -{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-} - - --- ---------------------------------------------------------------------------- --- * Basic stream functions - -length :: Stream Char -> Int -length = S.lengthI -{-# INLINE[0] length #-} - --- | /O(n)/ Reverse the characters of a string. -reverse :: Stream Char -> Text -reverse (Stream next s len0) - | isEmpty len0 = I.empty - | otherwise = I.textP arr off' len' - where - len0' = upperBound 4 (larger len0 4) - (arr, (off', len')) = A.run2 (A.new 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 -> {-# SCC "reverse/resize" #-} do - let newLen = len `shiftL` 1 - marr' <- A.new newLen - A.copyM marr' (newLen-len) marr 0 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 t j l mar - | n < 0x10000 = do - A.unsafeWrite mar j (fromIntegral n) - loop t (j-1) l mar - | otherwise = do - A.unsafeWrite mar (j-1) lo - A.unsafeWrite mar j hi - loop t (j-2) l mar -{-# INLINE [0] reverse #-} - --- | /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) -- HINT maybe too low - where - {-# INLINE next #-} - next (S1 :*: z :*: s) = Yield z (S2 :*: z :*: s) - next (S2 :*: z :*: s) = case next0 s of - Yield x s' -> let !x' = f x z - in Yield x' (S2 :*: x' :*: s') - Skip s' -> Skip (S2 :*: z :*: s') - Done -> Done -{-# INLINE reverseScanr #-} - --- | /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 = S.unfoldrNI n -{-# INLINE [0] unfoldrN #-} - -------------------------------------------------------------------------------- --- ** Indexing streams - --- | /O(n)/ stream index (subscript) operator, starting from 0. -index :: Stream Char -> Int -> Char -index = S.indexI -{-# INLINE [0] index #-} - --- | The 'findIndex' function takes a predicate and a stream and --- returns the index of the first element in the stream --- satisfying the predicate. -findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int -findIndex = S.findIndexI -{-# INLINE [0] findIndex #-} - --- | /O(n)/ The 'count' function returns the number of times the query --- element appears in the given stream. -countChar :: Char -> Stream Char -> Int -countChar = S.countCharI -{-# INLINE [0] countChar #-} - --- | /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 -> Stream Char -> (a, Text) -mapAccumL f z0 (Stream next0 s0 len) = (nz,I.textP na 0 nl) - where - (na,(nz,nl)) = A.run2 (A.new mlen >>= \arr -> outer arr mlen z0 s0 0) - where mlen = upperBound 4 len - outer arr top = loop - where - loop !z !s !i = - case next0 s of - Done -> return (arr, (z,i)) - Skip s' -> loop z s' i - Yield x s' - | j >= top -> {-# SCC "mapAccumL/resize" #-} do - let top' = (top + 1) `shiftL` 1 - arr' <- A.new top' - A.copyM arr' 0 arr 0 top - outer arr' top' z s i - | otherwise -> do d <- unsafeWrite arr i c - loop z' s' (i+d) - where (z',c) = f z x - j | ord c < 0x10000 = i - | otherwise = i + 1 -{-# INLINE [0] mapAccumL #-} diff --git a/Data/Text/Fusion/CaseMapping.hs b/Data/Text/Fusion/CaseMapping.hs deleted file mode 100644 --- a/Data/Text/Fusion/CaseMapping.hs +++ /dev/null @@ -1,570 +0,0 @@ -{-# LANGUAGE Rank2Types #-} --- AUTOMATICALLY GENERATED - DO NOT EDIT --- Generated by scripts/SpecialCasing.hs --- CaseFolding-6.3.0.txt --- Date: 2012-12-20, 22:14:35 GMT [MD] --- SpecialCasing-6.3.0.txt --- Date: 2013-05-08, 13:54:51 GMT [MD] - -module Data.Text.Fusion.CaseMapping where -import Data.Char -import Data.Text.Fusion.Internal - -upperMapping :: forall s. Char -> s -> Step (CC s) Char -{-# INLINE upperMapping #-} --- LATIN SMALL LETTER SHARP S -upperMapping '\x00df' s = Yield '\x0053' (CC s '\x0053' '\x0000') --- LATIN SMALL LIGATURE FF -upperMapping '\xfb00' s = Yield '\x0046' (CC s '\x0046' '\x0000') --- LATIN SMALL LIGATURE FI -upperMapping '\xfb01' s = Yield '\x0046' (CC s '\x0049' '\x0000') --- LATIN SMALL LIGATURE FL -upperMapping '\xfb02' s = Yield '\x0046' (CC s '\x004c' '\x0000') --- LATIN SMALL LIGATURE FFI -upperMapping '\xfb03' s = Yield '\x0046' (CC s '\x0046' '\x0049') --- LATIN SMALL LIGATURE FFL -upperMapping '\xfb04' s = Yield '\x0046' (CC s '\x0046' '\x004c') --- LATIN SMALL LIGATURE LONG S T -upperMapping '\xfb05' s = Yield '\x0053' (CC s '\x0054' '\x0000') --- LATIN SMALL LIGATURE ST -upperMapping '\xfb06' s = Yield '\x0053' (CC s '\x0054' '\x0000') --- ARMENIAN SMALL LIGATURE ECH YIWN -upperMapping '\x0587' s = Yield '\x0535' (CC s '\x0552' '\x0000') --- ARMENIAN SMALL LIGATURE MEN NOW -upperMapping '\xfb13' s = Yield '\x0544' (CC s '\x0546' '\x0000') --- ARMENIAN SMALL LIGATURE MEN ECH -upperMapping '\xfb14' s = Yield '\x0544' (CC s '\x0535' '\x0000') --- ARMENIAN SMALL LIGATURE MEN INI -upperMapping '\xfb15' s = Yield '\x0544' (CC s '\x053b' '\x0000') --- ARMENIAN SMALL LIGATURE VEW NOW -upperMapping '\xfb16' s = Yield '\x054e' (CC s '\x0546' '\x0000') --- ARMENIAN SMALL LIGATURE MEN XEH -upperMapping '\xfb17' s = Yield '\x0544' (CC s '\x053d' '\x0000') --- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE -upperMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000') --- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS -upperMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301') --- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS -upperMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301') --- LATIN SMALL LETTER J WITH CARON -upperMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000') --- LATIN SMALL LETTER H WITH LINE BELOW -upperMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000') --- LATIN SMALL LETTER T WITH DIAERESIS -upperMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000') --- LATIN SMALL LETTER W WITH RING ABOVE -upperMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000') --- LATIN SMALL LETTER Y WITH RING ABOVE -upperMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000') --- LATIN SMALL LETTER A WITH RIGHT HALF RING -upperMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000') --- GREEK SMALL LETTER UPSILON WITH PSILI -upperMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000') --- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA -upperMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300') --- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA -upperMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301') --- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI -upperMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342') --- GREEK SMALL LETTER ALPHA WITH PERISPOMENI -upperMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000') --- GREEK SMALL LETTER ETA WITH PERISPOMENI -upperMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000') --- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA -upperMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300') --- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA -upperMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301') --- GREEK SMALL LETTER IOTA WITH PERISPOMENI -upperMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000') --- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI -upperMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342') --- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA -upperMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300') --- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA -upperMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301') --- GREEK SMALL LETTER RHO WITH PSILI -upperMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000') --- GREEK SMALL LETTER UPSILON WITH PERISPOMENI -upperMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000') --- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI -upperMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342') --- GREEK SMALL LETTER OMEGA WITH PERISPOMENI -upperMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000') --- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI -upperMapping '\x1f80' s = Yield '\x1f08' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI -upperMapping '\x1f81' s = Yield '\x1f09' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI -upperMapping '\x1f82' s = Yield '\x1f0a' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI -upperMapping '\x1f83' s = Yield '\x1f0b' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI -upperMapping '\x1f84' s = Yield '\x1f0c' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI -upperMapping '\x1f85' s = Yield '\x1f0d' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI -upperMapping '\x1f86' s = Yield '\x1f0e' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI -upperMapping '\x1f87' s = Yield '\x1f0f' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI -upperMapping '\x1f88' s = Yield '\x1f08' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI -upperMapping '\x1f89' s = Yield '\x1f09' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI -upperMapping '\x1f8a' s = Yield '\x1f0a' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI -upperMapping '\x1f8b' s = Yield '\x1f0b' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI -upperMapping '\x1f8c' s = Yield '\x1f0c' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI -upperMapping '\x1f8d' s = Yield '\x1f0d' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI -upperMapping '\x1f8e' s = Yield '\x1f0e' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI -upperMapping '\x1f8f' s = Yield '\x1f0f' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI -upperMapping '\x1f90' s = Yield '\x1f28' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI -upperMapping '\x1f91' s = Yield '\x1f29' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI -upperMapping '\x1f92' s = Yield '\x1f2a' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI -upperMapping '\x1f93' s = Yield '\x1f2b' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI -upperMapping '\x1f94' s = Yield '\x1f2c' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI -upperMapping '\x1f95' s = Yield '\x1f2d' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI -upperMapping '\x1f96' s = Yield '\x1f2e' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI -upperMapping '\x1f97' s = Yield '\x1f2f' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI -upperMapping '\x1f98' s = Yield '\x1f28' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI -upperMapping '\x1f99' s = Yield '\x1f29' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI -upperMapping '\x1f9a' s = Yield '\x1f2a' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI -upperMapping '\x1f9b' s = Yield '\x1f2b' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI -upperMapping '\x1f9c' s = Yield '\x1f2c' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI -upperMapping '\x1f9d' s = Yield '\x1f2d' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI -upperMapping '\x1f9e' s = Yield '\x1f2e' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI -upperMapping '\x1f9f' s = Yield '\x1f2f' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI -upperMapping '\x1fa0' s = Yield '\x1f68' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI -upperMapping '\x1fa1' s = Yield '\x1f69' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI -upperMapping '\x1fa2' s = Yield '\x1f6a' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI -upperMapping '\x1fa3' s = Yield '\x1f6b' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI -upperMapping '\x1fa4' s = Yield '\x1f6c' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI -upperMapping '\x1fa5' s = Yield '\x1f6d' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI -upperMapping '\x1fa6' s = Yield '\x1f6e' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI -upperMapping '\x1fa7' s = Yield '\x1f6f' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI -upperMapping '\x1fa8' s = Yield '\x1f68' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI -upperMapping '\x1fa9' s = Yield '\x1f69' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI -upperMapping '\x1faa' s = Yield '\x1f6a' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI -upperMapping '\x1fab' s = Yield '\x1f6b' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI -upperMapping '\x1fac' s = Yield '\x1f6c' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI -upperMapping '\x1fad' s = Yield '\x1f6d' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI -upperMapping '\x1fae' s = Yield '\x1f6e' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI -upperMapping '\x1faf' s = Yield '\x1f6f' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI -upperMapping '\x1fb3' s = Yield '\x0391' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI -upperMapping '\x1fbc' s = Yield '\x0391' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI -upperMapping '\x1fc3' s = Yield '\x0397' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI -upperMapping '\x1fcc' s = Yield '\x0397' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI -upperMapping '\x1ff3' s = Yield '\x03a9' (CC s '\x0399' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI -upperMapping '\x1ffc' s = Yield '\x03a9' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI -upperMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI -upperMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI -upperMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI -upperMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI -upperMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI -upperMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0399' '\x0000') --- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI -upperMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0399') --- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI -upperMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0399') --- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI -upperMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0399') -upperMapping c s = Yield (toUpper c) (CC s '\0' '\0') -lowerMapping :: forall s. Char -> s -> Step (CC s) Char -{-# INLINE lowerMapping #-} --- LATIN CAPITAL LETTER I WITH DOT ABOVE -lowerMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000') -lowerMapping c s = Yield (toLower c) (CC s '\0' '\0') -titleMapping :: forall s. Char -> s -> Step (CC s) Char -{-# INLINE titleMapping #-} --- LATIN SMALL LETTER SHARP S -titleMapping '\x00df' s = Yield '\x0053' (CC s '\x0073' '\x0000') --- LATIN SMALL LIGATURE FF -titleMapping '\xfb00' s = Yield '\x0046' (CC s '\x0066' '\x0000') --- LATIN SMALL LIGATURE FI -titleMapping '\xfb01' s = Yield '\x0046' (CC s '\x0069' '\x0000') --- LATIN SMALL LIGATURE FL -titleMapping '\xfb02' s = Yield '\x0046' (CC s '\x006c' '\x0000') --- LATIN SMALL LIGATURE FFI -titleMapping '\xfb03' s = Yield '\x0046' (CC s '\x0066' '\x0069') --- LATIN SMALL LIGATURE FFL -titleMapping '\xfb04' s = Yield '\x0046' (CC s '\x0066' '\x006c') --- LATIN SMALL LIGATURE LONG S T -titleMapping '\xfb05' s = Yield '\x0053' (CC s '\x0074' '\x0000') --- LATIN SMALL LIGATURE ST -titleMapping '\xfb06' s = Yield '\x0053' (CC s '\x0074' '\x0000') --- ARMENIAN SMALL LIGATURE ECH YIWN -titleMapping '\x0587' s = Yield '\x0535' (CC s '\x0582' '\x0000') --- ARMENIAN SMALL LIGATURE MEN NOW -titleMapping '\xfb13' s = Yield '\x0544' (CC s '\x0576' '\x0000') --- ARMENIAN SMALL LIGATURE MEN ECH -titleMapping '\xfb14' s = Yield '\x0544' (CC s '\x0565' '\x0000') --- ARMENIAN SMALL LIGATURE MEN INI -titleMapping '\xfb15' s = Yield '\x0544' (CC s '\x056b' '\x0000') --- ARMENIAN SMALL LIGATURE VEW NOW -titleMapping '\xfb16' s = Yield '\x054e' (CC s '\x0576' '\x0000') --- ARMENIAN SMALL LIGATURE MEN XEH -titleMapping '\xfb17' s = Yield '\x0544' (CC s '\x056d' '\x0000') --- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE -titleMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000') --- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS -titleMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301') --- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS -titleMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301') --- LATIN SMALL LETTER J WITH CARON -titleMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000') --- LATIN SMALL LETTER H WITH LINE BELOW -titleMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000') --- LATIN SMALL LETTER T WITH DIAERESIS -titleMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000') --- LATIN SMALL LETTER W WITH RING ABOVE -titleMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000') --- LATIN SMALL LETTER Y WITH RING ABOVE -titleMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000') --- LATIN SMALL LETTER A WITH RIGHT HALF RING -titleMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000') --- GREEK SMALL LETTER UPSILON WITH PSILI -titleMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000') --- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA -titleMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300') --- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA -titleMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301') --- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI -titleMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342') --- GREEK SMALL LETTER ALPHA WITH PERISPOMENI -titleMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000') --- GREEK SMALL LETTER ETA WITH PERISPOMENI -titleMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000') --- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA -titleMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300') --- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA -titleMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301') --- GREEK SMALL LETTER IOTA WITH PERISPOMENI -titleMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000') --- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI -titleMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342') --- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA -titleMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300') --- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA -titleMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301') --- GREEK SMALL LETTER RHO WITH PSILI -titleMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000') --- GREEK SMALL LETTER UPSILON WITH PERISPOMENI -titleMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000') --- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI -titleMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342') --- GREEK SMALL LETTER OMEGA WITH PERISPOMENI -titleMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000') --- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI -titleMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0345' '\x0000') --- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI -titleMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0345' '\x0000') --- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI -titleMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0345' '\x0000') --- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI -titleMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0345' '\x0000') --- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI -titleMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0345' '\x0000') --- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI -titleMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0345' '\x0000') --- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI -titleMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0345') --- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI -titleMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0345') --- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI -titleMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0345') -titleMapping c s = Yield (toTitle c) (CC s '\0' '\0') -foldMapping :: forall s. Char -> s -> Step (CC s) Char -{-# INLINE foldMapping #-} --- MICRO SIGN -foldMapping '\x00b5' s = Yield '\x03bc' (CC s '\x0000' '\x0000') --- LATIN SMALL LETTER SHARP S -foldMapping '\x00df' s = Yield '\x0073' (CC s '\x0073' '\x0000') --- LATIN CAPITAL LETTER I WITH DOT ABOVE -foldMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000') --- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE -foldMapping '\x0149' s = Yield '\x02bc' (CC s '\x006e' '\x0000') --- LATIN SMALL LETTER LONG S -foldMapping '\x017f' s = Yield '\x0073' (CC s '\x0000' '\x0000') --- LATIN SMALL LETTER J WITH CARON -foldMapping '\x01f0' s = Yield '\x006a' (CC s '\x030c' '\x0000') --- COMBINING GREEK YPOGEGRAMMENI -foldMapping '\x0345' s = Yield '\x03b9' (CC s '\x0000' '\x0000') --- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS -foldMapping '\x0390' s = Yield '\x03b9' (CC s '\x0308' '\x0301') --- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS -foldMapping '\x03b0' s = Yield '\x03c5' (CC s '\x0308' '\x0301') --- GREEK SMALL LETTER FINAL SIGMA -foldMapping '\x03c2' s = Yield '\x03c3' (CC s '\x0000' '\x0000') --- GREEK BETA SYMBOL -foldMapping '\x03d0' s = Yield '\x03b2' (CC s '\x0000' '\x0000') --- GREEK THETA SYMBOL -foldMapping '\x03d1' s = Yield '\x03b8' (CC s '\x0000' '\x0000') --- GREEK PHI SYMBOL -foldMapping '\x03d5' s = Yield '\x03c6' (CC s '\x0000' '\x0000') --- GREEK PI SYMBOL -foldMapping '\x03d6' s = Yield '\x03c0' (CC s '\x0000' '\x0000') --- GREEK KAPPA SYMBOL -foldMapping '\x03f0' s = Yield '\x03ba' (CC s '\x0000' '\x0000') --- GREEK RHO SYMBOL -foldMapping '\x03f1' s = Yield '\x03c1' (CC s '\x0000' '\x0000') --- GREEK LUNATE EPSILON SYMBOL -foldMapping '\x03f5' s = Yield '\x03b5' (CC s '\x0000' '\x0000') --- ARMENIAN SMALL LIGATURE ECH YIWN -foldMapping '\x0587' s = Yield '\x0565' (CC s '\x0582' '\x0000') --- GEORGIAN CAPITAL LETTER YN -foldMapping '\x10c7' s = Yield '\x2d27' (CC s '\x0000' '\x0000') --- GEORGIAN CAPITAL LETTER AEN -foldMapping '\x10cd' s = Yield '\x2d2d' (CC s '\x0000' '\x0000') --- LATIN SMALL LETTER H WITH LINE BELOW -foldMapping '\x1e96' s = Yield '\x0068' (CC s '\x0331' '\x0000') --- LATIN SMALL LETTER T WITH DIAERESIS -foldMapping '\x1e97' s = Yield '\x0074' (CC s '\x0308' '\x0000') --- LATIN SMALL LETTER W WITH RING ABOVE -foldMapping '\x1e98' s = Yield '\x0077' (CC s '\x030a' '\x0000') --- LATIN SMALL LETTER Y WITH RING ABOVE -foldMapping '\x1e99' s = Yield '\x0079' (CC s '\x030a' '\x0000') --- LATIN SMALL LETTER A WITH RIGHT HALF RING -foldMapping '\x1e9a' s = Yield '\x0061' (CC s '\x02be' '\x0000') --- LATIN SMALL LETTER LONG S WITH DOT ABOVE -foldMapping '\x1e9b' s = Yield '\x1e61' (CC s '\x0000' '\x0000') --- LATIN CAPITAL LETTER SHARP S -foldMapping '\x1e9e' s = Yield '\x0073' (CC s '\x0073' '\x0000') --- GREEK SMALL LETTER UPSILON WITH PSILI -foldMapping '\x1f50' s = Yield '\x03c5' (CC s '\x0313' '\x0000') --- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA -foldMapping '\x1f52' s = Yield '\x03c5' (CC s '\x0313' '\x0300') --- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA -foldMapping '\x1f54' s = Yield '\x03c5' (CC s '\x0313' '\x0301') --- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI -foldMapping '\x1f56' s = Yield '\x03c5' (CC s '\x0313' '\x0342') --- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI -foldMapping '\x1f80' s = Yield '\x1f00' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI -foldMapping '\x1f81' s = Yield '\x1f01' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI -foldMapping '\x1f82' s = Yield '\x1f02' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI -foldMapping '\x1f83' s = Yield '\x1f03' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI -foldMapping '\x1f84' s = Yield '\x1f04' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI -foldMapping '\x1f85' s = Yield '\x1f05' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI -foldMapping '\x1f86' s = Yield '\x1f06' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI -foldMapping '\x1f87' s = Yield '\x1f07' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI -foldMapping '\x1f88' s = Yield '\x1f00' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI -foldMapping '\x1f89' s = Yield '\x1f01' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI -foldMapping '\x1f8a' s = Yield '\x1f02' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI -foldMapping '\x1f8b' s = Yield '\x1f03' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI -foldMapping '\x1f8c' s = Yield '\x1f04' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI -foldMapping '\x1f8d' s = Yield '\x1f05' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI -foldMapping '\x1f8e' s = Yield '\x1f06' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI -foldMapping '\x1f8f' s = Yield '\x1f07' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI -foldMapping '\x1f90' s = Yield '\x1f20' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI -foldMapping '\x1f91' s = Yield '\x1f21' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI -foldMapping '\x1f92' s = Yield '\x1f22' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI -foldMapping '\x1f93' s = Yield '\x1f23' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI -foldMapping '\x1f94' s = Yield '\x1f24' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI -foldMapping '\x1f95' s = Yield '\x1f25' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI -foldMapping '\x1f96' s = Yield '\x1f26' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI -foldMapping '\x1f97' s = Yield '\x1f27' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI -foldMapping '\x1f98' s = Yield '\x1f20' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI -foldMapping '\x1f99' s = Yield '\x1f21' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI -foldMapping '\x1f9a' s = Yield '\x1f22' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI -foldMapping '\x1f9b' s = Yield '\x1f23' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI -foldMapping '\x1f9c' s = Yield '\x1f24' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI -foldMapping '\x1f9d' s = Yield '\x1f25' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI -foldMapping '\x1f9e' s = Yield '\x1f26' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI -foldMapping '\x1f9f' s = Yield '\x1f27' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI -foldMapping '\x1fa0' s = Yield '\x1f60' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI -foldMapping '\x1fa1' s = Yield '\x1f61' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI -foldMapping '\x1fa2' s = Yield '\x1f62' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI -foldMapping '\x1fa3' s = Yield '\x1f63' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI -foldMapping '\x1fa4' s = Yield '\x1f64' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI -foldMapping '\x1fa5' s = Yield '\x1f65' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI -foldMapping '\x1fa6' s = Yield '\x1f66' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI -foldMapping '\x1fa7' s = Yield '\x1f67' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI -foldMapping '\x1fa8' s = Yield '\x1f60' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI -foldMapping '\x1fa9' s = Yield '\x1f61' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI -foldMapping '\x1faa' s = Yield '\x1f62' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI -foldMapping '\x1fab' s = Yield '\x1f63' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI -foldMapping '\x1fac' s = Yield '\x1f64' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI -foldMapping '\x1fad' s = Yield '\x1f65' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI -foldMapping '\x1fae' s = Yield '\x1f66' (CC s '\x03b9' '\x0000') --- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI -foldMapping '\x1faf' s = Yield '\x1f67' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI -foldMapping '\x1fb2' s = Yield '\x1f70' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI -foldMapping '\x1fb3' s = Yield '\x03b1' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI -foldMapping '\x1fb4' s = Yield '\x03ac' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ALPHA WITH PERISPOMENI -foldMapping '\x1fb6' s = Yield '\x03b1' (CC s '\x0342' '\x0000') --- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI -foldMapping '\x1fb7' s = Yield '\x03b1' (CC s '\x0342' '\x03b9') --- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI -foldMapping '\x1fbc' s = Yield '\x03b1' (CC s '\x03b9' '\x0000') --- GREEK PROSGEGRAMMENI -foldMapping '\x1fbe' s = Yield '\x03b9' (CC s '\x0000' '\x0000') --- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI -foldMapping '\x1fc2' s = Yield '\x1f74' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI -foldMapping '\x1fc3' s = Yield '\x03b7' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI -foldMapping '\x1fc4' s = Yield '\x03ae' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER ETA WITH PERISPOMENI -foldMapping '\x1fc6' s = Yield '\x03b7' (CC s '\x0342' '\x0000') --- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI -foldMapping '\x1fc7' s = Yield '\x03b7' (CC s '\x0342' '\x03b9') --- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI -foldMapping '\x1fcc' s = Yield '\x03b7' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA -foldMapping '\x1fd2' s = Yield '\x03b9' (CC s '\x0308' '\x0300') --- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA -foldMapping '\x1fd3' s = Yield '\x03b9' (CC s '\x0308' '\x0301') --- GREEK SMALL LETTER IOTA WITH PERISPOMENI -foldMapping '\x1fd6' s = Yield '\x03b9' (CC s '\x0342' '\x0000') --- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI -foldMapping '\x1fd7' s = Yield '\x03b9' (CC s '\x0308' '\x0342') --- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA -foldMapping '\x1fe2' s = Yield '\x03c5' (CC s '\x0308' '\x0300') --- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA -foldMapping '\x1fe3' s = Yield '\x03c5' (CC s '\x0308' '\x0301') --- GREEK SMALL LETTER RHO WITH PSILI -foldMapping '\x1fe4' s = Yield '\x03c1' (CC s '\x0313' '\x0000') --- GREEK SMALL LETTER UPSILON WITH PERISPOMENI -foldMapping '\x1fe6' s = Yield '\x03c5' (CC s '\x0342' '\x0000') --- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI -foldMapping '\x1fe7' s = Yield '\x03c5' (CC s '\x0308' '\x0342') --- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI -foldMapping '\x1ff2' s = Yield '\x1f7c' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI -foldMapping '\x1ff3' s = Yield '\x03c9' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI -foldMapping '\x1ff4' s = Yield '\x03ce' (CC s '\x03b9' '\x0000') --- GREEK SMALL LETTER OMEGA WITH PERISPOMENI -foldMapping '\x1ff6' s = Yield '\x03c9' (CC s '\x0342' '\x0000') --- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI -foldMapping '\x1ff7' s = Yield '\x03c9' (CC s '\x0342' '\x03b9') --- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI -foldMapping '\x1ffc' s = Yield '\x03c9' (CC s '\x03b9' '\x0000') --- COPTIC CAPITAL LETTER BOHAIRIC KHEI -foldMapping '\x2cf2' s = Yield '\x2cf3' (CC s '\x0000' '\x0000') --- LATIN CAPITAL LETTER C WITH BAR -foldMapping '\xa792' s = Yield '\xa793' (CC s '\x0000' '\x0000') --- LATIN CAPITAL LETTER H WITH HOOK -foldMapping '\xa7aa' s = Yield '\x0266' (CC s '\x0000' '\x0000') --- LATIN SMALL LIGATURE FF -foldMapping '\xfb00' s = Yield '\x0066' (CC s '\x0066' '\x0000') --- LATIN SMALL LIGATURE FI -foldMapping '\xfb01' s = Yield '\x0066' (CC s '\x0069' '\x0000') --- LATIN SMALL LIGATURE FL -foldMapping '\xfb02' s = Yield '\x0066' (CC s '\x006c' '\x0000') --- LATIN SMALL LIGATURE FFI -foldMapping '\xfb03' s = Yield '\x0066' (CC s '\x0066' '\x0069') --- LATIN SMALL LIGATURE FFL -foldMapping '\xfb04' s = Yield '\x0066' (CC s '\x0066' '\x006c') --- LATIN SMALL LIGATURE LONG S T -foldMapping '\xfb05' s = Yield '\x0073' (CC s '\x0074' '\x0000') --- LATIN SMALL LIGATURE ST -foldMapping '\xfb06' s = Yield '\x0073' (CC s '\x0074' '\x0000') --- ARMENIAN SMALL LIGATURE MEN NOW -foldMapping '\xfb13' s = Yield '\x0574' (CC s '\x0576' '\x0000') --- ARMENIAN SMALL LIGATURE MEN ECH -foldMapping '\xfb14' s = Yield '\x0574' (CC s '\x0565' '\x0000') --- ARMENIAN SMALL LIGATURE MEN INI -foldMapping '\xfb15' s = Yield '\x0574' (CC s '\x056b' '\x0000') --- ARMENIAN SMALL LIGATURE VEW NOW -foldMapping '\xfb16' s = Yield '\x057e' (CC s '\x0576' '\x0000') --- ARMENIAN SMALL LIGATURE MEN XEH -foldMapping '\xfb17' s = Yield '\x0574' (CC s '\x056d' '\x0000') -foldMapping c s = Yield (toLower c) (CC s '\0' '\0') diff --git a/Data/Text/Fusion/Common.hs b/Data/Text/Fusion/Common.hs deleted file mode 100644 --- a/Data/Text/Fusion/Common.hs +++ /dev/null @@ -1,947 +0,0 @@ -{-# LANGUAGE BangPatterns, MagicHash, Rank2Types #-} --- | --- Module : Data.Text.Fusion.Common --- Copyright : (c) Bryan O'Sullivan 2009, 2012 --- --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org --- Stability : experimental --- Portability : GHC --- --- Common stream fusion functionality for text. - -module Data.Text.Fusion.Common - ( - -- * Creation and elimination - singleton - , streamList - , unstreamList - , streamCString# - - -- * Basic interface - , cons - , snoc - , append - , head - , uncons - , last - , tail - , init - , null - , lengthI - , compareLengthI - , isSingleton - - -- * Transformations - , map - , intercalate - , intersperse - - -- ** Case conversion - -- $case - , toCaseFold - , toLower - , toTitle - , toUpper - - -- ** Justification - , justifyLeftI - - -- * Folds - , foldl - , foldl' - , foldl1 - , foldl1' - , foldr - , foldr1 - - -- ** Special folds - , concat - , concatMap - , any - , all - , maximum - , minimum - - -- * Construction - -- ** Scans - , scanl - - -- ** Accumulating maps - -- , mapAccumL - - -- ** Generation and unfolding - , replicateCharI - , replicateI - , unfoldr - , unfoldrNI - - -- * Substrings - -- ** Breaking strings - , take - , drop - , takeWhile - , dropWhile - - -- * Predicates - , isPrefixOf - - -- * Searching - , elem - , filter - - -- * Indexing - , findBy - , indexI - , findIndexI - , countCharI - - -- * Zipping and unzipping - , zipWith - ) where - -import Prelude (Bool(..), Char, Eq(..), Int, Integral, Maybe(..), - Ord(..), Ordering(..), String, (.), ($), (+), (-), (*), (++), - (&&), fromIntegral, not, otherwise) -import qualified Data.List as L -import qualified Prelude as P -import Data.Bits (shiftL) -import Data.Char (isLetter) -import Data.Int (Int64) -import Data.Text.Fusion.Internal -import Data.Text.Fusion.CaseMapping (foldMapping, lowerMapping, titleMapping, - upperMapping) -import Data.Text.Fusion.Size -import GHC.Prim (Addr#, chr#, indexCharOffAddr#, ord#) -import GHC.Types (Char(..), Int(..)) - -singleton :: Char -> Stream Char -singleton c = Stream next False 1 - where next False = Yield c True - next True = Done -{-# INLINE singleton #-} - -streamList :: [a] -> Stream a -{-# INLINE [0] streamList #-} -streamList s = Stream next s unknownSize - where next [] = Done - next (x:xs) = Yield x xs - -unstreamList :: Stream a -> [a] -unstreamList (Stream next s0 _len) = unfold s0 - where unfold !s = case next s of - Done -> [] - Skip s' -> unfold s' - Yield x s' -> x : unfold s' -{-# INLINE [0] unstreamList #-} - -{-# RULES "STREAM streamList/unstreamList fusion" forall s. streamList (unstreamList s) = s #-} - --- | Stream the UTF-8-like packed encoding used by GHC to represent --- constant strings in generated code. --- --- This encoding uses the byte sequence "\xc0\x80" to represent NUL, --- and the string is NUL-terminated. -streamCString# :: Addr# -> Stream Char -streamCString# addr = Stream step 0 unknownSize - where - step !i - | b == 0 = Done - | b <= 0x7f = Yield (C# b#) (i+1) - | b <= 0xdf = let !c = chr $ ((b-0xc0) `shiftL` 6) + next 1 - in Yield c (i+2) - | b <= 0xef = let !c = chr $ ((b-0xe0) `shiftL` 12) + - (next 1 `shiftL` 6) + - next 2 - in Yield c (i+3) - | otherwise = let !c = chr $ ((b-0xf0) `shiftL` 18) + - (next 1 `shiftL` 12) + - (next 2 `shiftL` 6) + - next 3 - in Yield c (i+4) - where b = I# (ord# b#) - next n = I# (ord# (at# (i+n))) - 0x80 - !b# = at# i - at# (I# i#) = indexCharOffAddr# addr i# - chr (I# i#) = C# (chr# i#) -{-# INLINE [0] streamCString# #-} - --- ---------------------------------------------------------------------------- --- * Basic stream functions - -data C s = C0 !s - | C1 !s - --- | /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 (C1 s0) (len+1) - where - next (C1 s) = Yield w (C0 s) - next (C0 s) = case next0 s of - Done -> Done - Skip s' -> Skip (C0 s') - Yield x s' -> Yield x (C0 s') -{-# INLINE [0] cons #-} - --- | /O(n)/ Adds a character to the end of a stream. -snoc :: Stream Char -> Char -> Stream Char -snoc (Stream next0 xs0 len) w = Stream next (J xs0) (len+1) - where - next (J xs) = case next0 xs of - Done -> Yield w N - Skip xs' -> Skip (J xs') - Yield x xs' -> Yield x (J xs') - next N = Done -{-# INLINE [0] snoc #-} - -data E l r = L !l - | R !r - --- | /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 (L s01) (len1 + len2) - where - next (L s1) = case next0 s1 of - Done -> Skip (R s02) - Skip s1' -> Skip (L s1') - Yield x s1' -> Yield x (L s1') - next (R s2) = case next1 s2 of - Done -> Done - Skip s2' -> Skip (R s2') - Yield x s2' -> Yield x (R 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 -> head_empty -{-# INLINE [0] head #-} - -head_empty :: a -head_empty = streamError "head" "Empty stream" -{-# NOINLINE head_empty #-} - --- | /O(1)/ Returns the first character and remainder of a 'Stream --- Char', or 'Nothing' if empty. Subject to array fusion. -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 (C0 s0) (len-1) - where - next (C0 s) = case next0 s of - Done -> emptyError "tail" - Skip s' -> Skip (C0 s') - Yield _ s' -> Skip (C1 s') - next (C1 s) = case next0 s of - Done -> Done - Skip s' -> Skip (C1 s') - Yield x s' -> Yield x (C1 s') -{-# INLINE [0] tail #-} - -data Init s = Init0 !s - | Init1 {-# UNPACK #-} !Char !s - --- | /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 (Init0 s0) (len-1) - where - next (Init0 s) = case next0 s of - Done -> emptyError "init" - Skip s' -> Skip (Init0 s') - Yield x s' -> Skip (Init1 x s') - next (Init1 x s) = case next0 s of - Done -> Done - Skip s' -> Skip (Init1 x s') - Yield x' s' -> Yield x (Init1 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 string. -lengthI :: Integral a => Stream Char -> a -lengthI (Stream next s0 _len) = loop_length 0 s0 - where - loop_length !z s = case next s of - Done -> z - Skip s' -> loop_length z s' - Yield _ s' -> loop_length (z + 1) s' -{-# INLINE[0] lengthI #-} - --- | /O(n)/ Compares the count of characters in a string to a number. --- Subject to fusion. --- --- This function gives the same answer as comparing against the result --- of 'lengthI', but can short circuit if the count of characters is --- greater than the number, and hence be more efficient. -compareLengthI :: Integral a => Stream Char -> a -> Ordering -compareLengthI (Stream next s0 len) n = - case exactly len of - Nothing -> loop_cmp 0 s0 - Just i -> compare (fromIntegral i) n - where - loop_cmp !z s = case next s of - Done -> compare z n - Skip s' -> loop_cmp z s' - Yield _ s' | z > n -> GT - | otherwise -> loop_cmp (z + 1) s' -{-# INLINE[0] compareLengthI #-} - --- | /O(n)/ Indicate whether a string contains exactly one element. -isSingleton :: Stream Char -> Bool -isSingleton (Stream next s0 _len) = loop 0 s0 - where - loop !z s = case next s of - Done -> z == (1::Int) - Skip s' -> loop z s' - Yield _ s' - | z >= 1 -> False - | otherwise -> loop (z+1) s' -{-# INLINE[0] isSingleton #-} - --- ---------------------------------------------------------------------------- --- * 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 - 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 - #-} - -data I s = I1 !s - | I2 !s {-# UNPACK #-} !Char - | I3 !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 (I1 s0) len - where - next (I1 s) = case next0 s of - Done -> Done - Skip s' -> Skip (I1 s') - Yield x s' -> Skip (I2 s' x) - next (I2 s x) = Yield x (I3 s) - next (I3 s) = case next0 s of - Done -> Done - Skip s' -> Skip (I3 s') - Yield x s' -> Yield c (I2 s' x) -{-# INLINE [0] intersperse #-} - --- ---------------------------------------------------------------------------- --- ** Case conversions (folds) - --- $case --- --- With Unicode text, it is incorrect to use combinators like @map --- toUpper@ to case convert each character of a string individually. --- Instead, use the whole-string case conversion functions from this --- module. For correctness in different writing systems, these --- functions may map one input character to two or three output --- characters. - -caseConvert :: (forall s. Char -> s -> Step (CC s) Char) - -> Stream Char -> Stream Char -caseConvert remap (Stream next0 s0 len) = Stream next (CC s0 '\0' '\0') len - where - next (CC s '\0' _) = - case next0 s of - Done -> Done - Skip s' -> Skip (CC s' '\0' '\0') - Yield c s' -> remap c s' - next (CC s a b) = Yield a (CC s b '\0') - --- | /O(n)/ Convert a string to folded case. This function is mainly --- useful for performing caseless (or case insensitive) string --- comparisons. --- --- A string @x@ is a caseless match for a string @y@ if and only if: --- --- @toCaseFold x == toCaseFold y@ --- --- The result string may be longer than the input string, and may --- differ from applying 'toLower' to the input string. For instance, --- the Armenian small ligature men now (U+FB13) is case folded to the --- bigram men now (U+0574 U+0576), while the micro sign (U+00B5) is --- case folded to the Greek small letter letter mu (U+03BC) instead of --- itself. -toCaseFold :: Stream Char -> Stream Char -toCaseFold = caseConvert foldMapping -{-# INLINE [0] toCaseFold #-} - --- | /O(n)/ Convert a string to upper case, using simple case --- conversion. The result string may be longer than the input string. --- For instance, the German eszett (U+00DF) maps to the two-letter --- sequence SS. -toUpper :: Stream Char -> Stream Char -toUpper = caseConvert upperMapping -{-# INLINE [0] toUpper #-} - --- | /O(n)/ Convert a string to lower case, using simple case --- conversion. The result string may be longer than the input string. --- For instance, the Latin capital letter I with dot above (U+0130) --- maps to the sequence Latin small letter i (U+0069) followed by --- combining dot above (U+0307). -toLower :: Stream Char -> Stream Char -toLower = caseConvert lowerMapping -{-# INLINE [0] toLower #-} - --- | /O(n)/ Convert a string to title case, using simple case --- conversion. --- --- The first letter of the input is converted to title case, as is --- every subsequent letter that immediately follows a non-letter. --- Every letter that immediately follows another letter is converted --- to lower case. --- --- The result string may be longer than the input string. For example, --- the Latin small ligature fl (U+FB02) is converted to the --- sequence Latin capital letter F (U+0046) followed by Latin small --- letter l (U+006C). --- --- /Note/: this function does not take language or culture specific --- rules into account. For instance, in English, different style --- guides disagree on whether the book name \"The Hill of the Red --- Fox\" is correctly title cased—but this function will --- capitalize /every/ word. -toTitle :: Stream Char -> Stream Char -toTitle (Stream next0 s0 len) = Stream next (CC (False :*: s0) '\0' '\0') len - where - next (CC (letter :*: s) '\0' _) = - case next0 s of - Done -> Done - Skip s' -> Skip (CC (letter :*: s') '\0' '\0') - Yield c s' - | letter' -> if letter - then lowerMapping c (letter' :*: s') - else titleMapping c (letter' :*: s') - | otherwise -> Yield c (CC (letter' :*: s') '\0' '\0') - where letter' = isLetter c - next (CC s a b) = Yield a (CC s b '\0') -{-# INLINE [0] toTitle #-} - -justifyLeftI :: Integral a => a -> Char -> Stream Char -> Stream Char -justifyLeftI k c (Stream next0 s0 len) = - Stream next (s0 :*: S1 :*: 0) (larger (fromIntegral k) len) - where - next (s :*: S1 :*: n) = - case next0 s of - Done -> next (s :*: S2 :*: n) - Skip s' -> Skip (s' :*: S1 :*: n) - Yield x s' -> Yield x (s' :*: S1 :*: n+1) - next (s :*: S2 :*: n) - | n < k = Yield c (s :*: S2 :*: n+1) - | otherwise = Done - {-# INLINE next #-} -{-# INLINE [0] justifyLeftI #-} - --- ---------------------------------------------------------------------------- --- * Reducing Streams (folds) - --- | foldl, applied to a binary operator, a starting value (typically the --- left-identity of the operator), and a Stream, reduces the Stream using the --- binary operator, from left to right. -foldl :: (b -> Char -> b) -> b -> Stream Char -> b -foldl f z0 (Stream next s0 _len) = loop_foldl z0 s0 - where - loop_foldl z !s = case next s of - Done -> z - Skip s' -> loop_foldl z s' - Yield x s' -> loop_foldl (f z x) s' -{-# INLINE [0] foldl #-} - --- | A strict version of foldl. -foldl' :: (b -> Char -> b) -> b -> Stream Char -> b -foldl' f z0 (Stream next s0 _len) = loop_foldl' z0 s0 - where - loop_foldl' !z !s = case next s of - Done -> z - Skip s' -> loop_foldl' z s' - Yield x s' -> loop_foldl' (f z x) s' -{-# INLINE [0] foldl' #-} - --- | foldl1 is a variant of foldl that has no starting value argument, --- and thus must be applied to non-empty Streams. -foldl1 :: (Char -> Char -> Char) -> Stream Char -> Char -foldl1 f (Stream next s0 _len) = loop0_foldl1 s0 - where - loop0_foldl1 !s = case next s of - Skip s' -> loop0_foldl1 s' - Yield x s' -> loop_foldl1 x s' - Done -> emptyError "foldl1" - loop_foldl1 z !s = case next s of - Done -> z - Skip s' -> loop_foldl1 z s' - Yield x s' -> loop_foldl1 (f z x) s' -{-# INLINE [0] foldl1 #-} - --- | A strict version of foldl1. -foldl1' :: (Char -> Char -> Char) -> Stream Char -> Char -foldl1' f (Stream next s0 _len) = loop0_foldl1' s0 - where - loop0_foldl1' !s = case next s of - Skip s' -> loop0_foldl1' s' - Yield x s' -> loop_foldl1' x s' - Done -> emptyError "foldl1" - loop_foldl1' !z !s = case next s of - Done -> z - Skip s' -> loop_foldl1' z s' - Yield x s' -> loop_foldl1' (f z x) s' -{-# INLINE [0] foldl1' #-} - --- | 'foldr', applied to a binary operator, a starting value (typically the --- right-identity of the operator), and a stream, reduces the stream using the --- binary operator, from right to left. -foldr :: (Char -> b -> b) -> b -> Stream Char -> b -foldr f z (Stream next s0 _len) = loop_foldr s0 - where - loop_foldr !s = case next s of - Done -> z - Skip s' -> loop_foldr s' - Yield x s' -> f x (loop_foldr s') -{-# INLINE [0] foldr #-} - --- | foldr1 is a variant of 'foldr' that has no starting value argument, --- and thus must be applied to non-empty streams. --- Subject to array fusion. -foldr1 :: (Char -> Char -> Char) -> Stream Char -> Char -foldr1 f (Stream next s0 _len) = loop0_foldr1 s0 - where - loop0_foldr1 !s = case next s of - Done -> emptyError "foldr1" - Skip s' -> loop0_foldr1 s' - Yield x s' -> loop_foldr1 x s' - - loop_foldr1 x !s = case next s of - Done -> x - Skip s' -> loop_foldr1 x s' - Yield x' s' -> f x (loop_foldr1 x' s') -{-# INLINE [0] foldr1 #-} - -intercalate :: Stream Char -> [Stream Char] -> Stream Char -intercalate s = concat . (L.intersperse s) -{-# INLINE [0] intercalate #-} - --- ---------------------------------------------------------------------------- --- ** Special folds - --- | /O(n)/ Concatenate a list of streams. Subject to array fusion. -concat :: [Stream Char] -> Stream Char -concat = L.foldr append empty -{-# INLINE [0] 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 -{-# INLINE [0] concatMap #-} - --- | /O(n)/ any @p @xs determines if any character in the stream --- @xs@ satisifes the predicate @p@. -any :: (Char -> Bool) -> Stream Char -> Bool -any p (Stream next0 s0 _len) = loop_any s0 - where - loop_any !s = case next0 s of - Done -> False - Skip s' -> loop_any s' - Yield x s' | p x -> True - | otherwise -> loop_any s' -{-# INLINE [0] any #-} - --- | /O(n)/ all @p @xs determines if all characters in the 'Text' --- @xs@ satisify the predicate @p@. -all :: (Char -> Bool) -> Stream Char -> Bool -all p (Stream next0 s0 _len) = loop_all s0 - where - loop_all !s = case next0 s of - Done -> True - Skip s' -> loop_all s' - Yield x s' | p x -> loop_all s' - | otherwise -> False -{-# INLINE [0] all #-} - --- | /O(n)/ maximum returns the maximum value from a stream, which must be --- non-empty. -maximum :: Stream Char -> Char -maximum (Stream next0 s0 _len) = loop0_maximum s0 - where - loop0_maximum !s = case next0 s of - Done -> emptyError "maximum" - Skip s' -> loop0_maximum s' - Yield x s' -> loop_maximum x s' - loop_maximum !z !s = case next0 s of - Done -> z - Skip s' -> loop_maximum z s' - Yield x s' - | x > z -> loop_maximum x s' - | otherwise -> loop_maximum z s' -{-# INLINE [0] maximum #-} - --- | /O(n)/ minimum returns the minimum value from a 'Text', which must be --- non-empty. -minimum :: Stream Char -> Char -minimum (Stream next0 s0 _len) = loop0_minimum s0 - where - loop0_minimum !s = case next0 s of - Done -> emptyError "minimum" - Skip s' -> loop0_minimum s' - Yield x s' -> loop_minimum x s' - loop_minimum !z !s = case next0 s of - Done -> z - Skip s' -> loop_minimum z s' - Yield x s' - | x < z -> loop_minimum x s' - | otherwise -> loop_minimum z s' -{-# INLINE [0] minimum #-} - --- ----------------------------------------------------------------------------- --- * Building streams - -scanl :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char -scanl f z0 (Stream next0 s0 len) = Stream next (S1 :*: z0 :*: s0) (len+1) -- HINT maybe too low - where - {-# INLINE next #-} - next (S1 :*: z :*: s) = Yield z (S2 :*: z :*: s) - next (S2 :*: z :*: s) = case next0 s of - Yield x s' -> let !x' = f z x - in Yield x' (S2 :*: x' :*: s') - Skip s' -> Skip (S2 :*: z :*: s') - Done -> Done -{-# INLINE [0] scanl #-} - --- ----------------------------------------------------------------------------- --- ** Accumulating maps - -{- --- | /O(n)/ Like a combination of 'map' and 'foldl'. Applies a --- function to each element of a stream, passing an accumulating --- parameter from left to right, and returns a final stream. --- --- /Note/: Unlike the version over lists, this function does not --- return a final value for the accumulator, because the nature of --- streams precludes it. -mapAccumL :: (a -> b -> (a,b)) -> a -> Stream b -> Stream b -mapAccumL f z0 (Stream next0 s0 len) = Stream next (s0 :*: z0) len -- HINT depends on f - where - {-# INLINE next #-} - next (s :*: z) = case next0 s of - Yield x s' -> let (z',y) = f z x - in Yield y (s' :*: z') - Skip s' -> Skip (s' :*: z) - Done -> Done -{-# INLINE [0] mapAccumL #-} --} - --- ----------------------------------------------------------------------------- --- ** Generating and unfolding streams - -replicateCharI :: Integral a => a -> Char -> Stream Char -replicateCharI n c - | n < 0 = empty - | otherwise = Stream next 0 (fromIntegral n) -- HINT maybe too low - where - next i | i >= n = Done - | otherwise = Yield c (i + 1) -{-# INLINE [0] replicateCharI #-} - -data RI s = RI !s {-# UNPACK #-} !Int64 - -replicateI :: Int64 -> Stream Char -> Stream Char -replicateI n (Stream next0 s0 len) = - Stream next (RI s0 0) (fromIntegral (max 0 n) * len) - where - next (RI s k) - | k >= n = Done - | otherwise = case next0 s of - Done -> Skip (RI s0 (k+1)) - Skip s' -> Skip (RI s' k) - Yield x s' -> Yield x (RI s' k) -{-# INLINE [0] replicateI #-} - --- | /O(n)/, where @n@ is the length of the result. The unfoldr function --- is analogous to the List 'unfoldr'. unfoldr builds a stream --- from a seed value. The function takes the element and returns --- Nothing if it is done producing the stream or returns Just --- (a,b), in which case, a is the next Char in the string, and b is --- the seed value for further production. -unfoldr :: (a -> Maybe (Char,a)) -> a -> Stream Char -unfoldr f s0 = Stream next s0 1 -- HINT maybe too low - where - {-# INLINE next #-} - next !s = case f s of - Nothing -> Done - Just (w, s') -> Yield w s' -{-# INLINE [0] unfoldr #-} - --- | /O(n)/ Like 'unfoldr', 'unfoldrNI' builds a stream from a seed --- value. However, the length of the result is limited by the --- first argument to 'unfoldrNI'. This function is more efficient than --- 'unfoldr' when the length of the result is known. -unfoldrNI :: Integral a => a -> (b -> Maybe (Char,b)) -> b -> Stream Char -unfoldrNI n f s0 | n < 0 = empty - | otherwise = Stream next (0 :*: s0) (fromIntegral (n*2)) -- HINT maybe too high - where - {-# INLINE next #-} - next (z :*: s) = case f s of - Nothing -> Done - Just (w, s') | z >= n -> Done - | otherwise -> Yield w ((z + 1) :*: s') -{-# INLINE unfoldrNI #-} - -------------------------------------------------------------------------------- --- * Substreams - --- | /O(n)/ take n, applied to a stream, returns the prefix of the --- stream of length @n@, or the stream itself if @n@ is greater than the --- length of the stream. -take :: Integral a => a -> Stream Char -> Stream Char -take n0 (Stream next0 s0 len) = - Stream next (n0 :*: s0) (smaller len (fromIntegral (max 0 n0))) - 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 after the first @n@ characters, or the empty stream if @n@ --- is greater than the length of the stream. -drop :: Integral a => a -> Stream Char -> Stream Char -drop n0 (Stream next0 s0 len) = - Stream next (J n0 :*: s0) (len - fromIntegral (max 0 n0)) - where - {-# INLINE next #-} - next (J n :*: s) - | n <= 0 = Skip (N :*: s) - | otherwise = case next0 s of - Done -> Done - Skip s' -> Skip (J n :*: s') - Yield _ s' -> Skip (J (n-1) :*: s') - next (N :*: s) = case next0 s of - Done -> Done - Skip s' -> Skip (N :*: s') - Yield x s' -> Yield x (N :*: s') -{-# INLINE [0] drop #-} - --- | takeWhile, applied to a predicate @p@ and a stream, returns the --- longest prefix (possibly empty) of elements that satisfy p. -takeWhile :: (Char -> Bool) -> Stream Char -> Stream Char -takeWhile p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high - where - {-# INLINE next #-} - next !s = case next0 s of - Done -> Done - Skip s' -> Skip s' - Yield x s' | p x -> Yield x s' - | otherwise -> Done -{-# INLINE [0] takeWhile #-} - --- | dropWhile @p @xs returns the suffix remaining after takeWhile @p @xs. -dropWhile :: (Char -> Bool) -> Stream Char -> Stream Char -dropWhile p (Stream next0 s0 len) = Stream next (S1 :*: s0) len -- HINT maybe too high - where - {-# INLINE next #-} - next (S1 :*: s) = case next0 s of - Done -> Done - Skip s' -> Skip (S1 :*: s') - Yield x s' | p x -> Skip (S1 :*: s') - | otherwise -> Yield x (S2 :*: s') - next (S2 :*: s) = case next0 s of - Done -> Done - Skip s' -> Skip (S2 :*: s') - Yield x s' -> Yield x (S2 :*: s') -{-# INLINE [0] dropWhile #-} - --- | /O(n)/ The 'isPrefixOf' function takes two 'Stream's and returns --- 'True' iff the first is a prefix of the second. -isPrefixOf :: (Eq a) => Stream a -> Stream a -> Bool -isPrefixOf (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2) - where - loop Done _ = True - loop _ Done = False - loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2') - loop (Skip s1') x2 = loop (next1 s1') x2 - loop x1 (Skip s2') = loop x1 (next2 s2') - loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 && - loop (next1 s1') (next2 s2') -{-# INLINE [0] isPrefixOf #-} - --- ---------------------------------------------------------------------------- --- * 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 'findBy' function takes a predicate and a stream, --- and returns the first element in matching the predicate, or 'Nothing' --- if there is no such element. - -findBy :: (Char -> Bool) -> Stream Char -> Maybe Char -findBy 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] findBy #-} - --- | /O(n)/ Stream index (subscript) operator, starting from 0. -indexI :: Integral a => Stream Char -> a -> Char -indexI (Stream next s0 _len) n0 - | n0 < 0 = streamError "index" "Negative index" - | otherwise = loop_index n0 s0 - where - loop_index !n !s = case next s of - Done -> streamError "index" "Index too large" - Skip s' -> loop_index n s' - Yield x s' | n == 0 -> x - | otherwise -> loop_index (n-1) s' -{-# INLINE [0] indexI #-} - --- | /O(n)/ 'filter', applied to a predicate and a stream, --- returns a stream containing those characters that satisfy the --- predicate. -filter :: (Char -> Bool) -> Stream Char -> Stream Char -filter p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high - where - next !s = case next0 s of - Done -> Done - Skip s' -> Skip s' - Yield x s' | p x -> Yield x s' - | otherwise -> Skip s' -{-# INLINE [0] filter #-} - -{-# RULES - "STREAM filter/filter fusion" forall p q s. - filter p (filter q s) = filter (\x -> q x && p x) s - #-} - --- | The 'findIndexI' function takes a predicate and a stream and --- returns the index of the first element in the stream satisfying the --- predicate. -findIndexI :: Integral a => (Char -> Bool) -> Stream Char -> Maybe a -findIndexI p s = case findIndicesI p s of - (i:_) -> Just i - _ -> Nothing -{-# INLINE [0] findIndexI #-} - --- | The 'findIndicesI' function takes a predicate and a stream and --- returns all indices of the elements in the stream satisfying the --- predicate. -findIndicesI :: Integral a => (Char -> Bool) -> Stream Char -> [a] -findIndicesI p (Stream next s0 _len) = loop_findIndex 0 s0 - where - loop_findIndex !i !s = case next s of - Done -> [] - Skip s' -> loop_findIndex i s' -- hmm. not caught by QC - Yield x s' | p x -> i : loop_findIndex (i+1) s' - | otherwise -> loop_findIndex (i+1) s' -{-# INLINE [0] findIndicesI #-} - -------------------------------------------------------------------------------- --- * Zipping - --- | zipWith generalises 'zip' by zipping with the function given as --- the first argument, instead of a tupling function. -zipWith :: (a -> a -> b) -> Stream a -> Stream a -> Stream b -zipWith f (Stream next0 sa0 len1) (Stream next1 sb0 len2) = - Stream next (sa0 :*: sb0 :*: N) (smaller len1 len2) - where - next (sa :*: sb :*: N) = case next0 sa of - Done -> Done - Skip sa' -> Skip (sa' :*: sb :*: N) - Yield a sa' -> Skip (sa' :*: sb :*: J a) - - next (sa' :*: sb :*: J a) = case next1 sb of - Done -> Done - Skip sb' -> Skip (sa' :*: sb' :*: J a) - Yield b sb' -> Yield (f a b) (sa' :*: sb' :*: N) -{-# INLINE [0] zipWith #-} - --- | /O(n)/ The 'countCharI' function returns the number of times the --- query element appears in the given stream. -countCharI :: Integral a => Char -> Stream Char -> a -countCharI 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] countCharI #-} - -streamError :: String -> String -> a -streamError func msg = P.error $ "Data.Text.Fusion.Common." ++ func ++ ": " ++ msg - -emptyError :: String -> a -emptyError func = internalError func "Empty input" - -internalError :: String -> a -internalError func = streamError func "Internal error" diff --git a/Data/Text/Fusion/Internal.hs b/Data/Text/Fusion/Internal.hs deleted file mode 100644 --- a/Data/Text/Fusion/Internal.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE BangPatterns, ExistentialQuantification #-} --- | --- Module : Data.Text.Fusion.Internal --- Copyright : (c) Tom Harper 2008-2009, --- (c) Bryan O'Sullivan 2009, --- (c) Duncan Coutts 2009, --- (c) Jasper Van der Jeugt 2011 --- --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org --- Stability : experimental --- Portability : GHC --- --- Core stream fusion functionality for text. - -module Data.Text.Fusion.Internal - ( - CC(..) - , M(..) - , M8 - , PairS(..) - , RS(..) - , Step(..) - , Stream(..) - , Switch(..) - , empty - ) where - -import Data.Text.Fusion.Size -import Data.Word (Word8) - --- | Specialised tuple for case conversion. -data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char - --- | Specialised, strict Maybe-like type. -data M a = N - | J !a - -type M8 = M Word8 - --- Restreaming state. -data RS s - = RS0 !s - | RS1 !s {-# UNPACK #-} !Word8 - | RS2 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 - | RS3 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 - -infixl 2 :*: -data PairS a b = !a :*: !b - -- deriving (Eq, Ord, Show) - --- | Allow a function over a stream to switch between two states. -data Switch = S1 | S2 - -data Step s a = Done - | Skip !s - | Yield !a !s - -{- -instance (Show a) => Show (Step s a) - where show Done = "Done" - show (Skip _) = "Skip" - show (Yield x _) = "Yield " ++ show x --} - -instance (Eq a) => Eq (Stream a) where - (==) = eq - -instance (Ord a) => Ord (Stream a) where - compare = cmp - --- The length hint in a Stream has two roles. If its value is zero, --- we trust it, and treat the stream as empty. Otherwise, we treat it --- as a hint: it should usually be accurate, so we use it when --- unstreaming to decide what size array to allocate. However, the --- unstreaming functions must be able to cope with the hint being too --- small or too large. --- --- The size hint tries to track the UTF-16 code points in a stream, --- but often counts the number of characters instead. It can easily --- undercount if, for instance, a transformed stream contains astral --- plane characters (those above 0x10000). - -data Stream a = - forall s. Stream - (s -> Step s a) -- stepper function - !s -- current state - !Size -- size hint - --- | /O(n)/ Determines if two streams are equal. -eq :: (Eq a) => Stream a -> Stream a -> Bool -eq (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2) - where - loop Done Done = True - loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2') - loop (Skip s1') x2 = loop (next1 s1') x2 - loop x1 (Skip s2') = loop x1 (next2 s2') - loop Done _ = False - loop _ Done = False - loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 && - loop (next1 s1') (next2 s2') -{-# INLINE [0] eq #-} - -cmp :: (Ord a) => Stream a -> Stream a -> Ordering -cmp (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2) - where - loop Done Done = EQ - loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2') - loop (Skip s1') x2 = loop (next1 s1') x2 - loop x1 (Skip s2') = loop x1 (next2 s2') - loop Done _ = LT - loop _ Done = GT - loop (Yield x1 s1') (Yield x2 s2') = - case compare x1 x2 of - EQ -> loop (next1 s1') (next2 s2') - other -> other -{-# INLINE [0] cmp #-} - --- | The empty stream. -empty :: Stream a -empty = Stream next () 0 - where next _ = Done -{-# INLINE [0] empty #-} diff --git a/Data/Text/Fusion/Size.hs b/Data/Text/Fusion/Size.hs deleted file mode 100644 --- a/Data/Text/Fusion/Size.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-missing-methods #-} --- | --- Module : Data.Text.Fusion.Internal --- Copyright : (c) Roman Leshchinskiy 2008, --- (c) Bryan O'Sullivan 2009 --- --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org --- Stability : experimental --- Portability : portable --- --- Size hints. - -module Data.Text.Fusion.Size - ( - Size - , exactly - , exactSize - , maxSize - , unknownSize - , smaller - , larger - , upperBound - , isEmpty - ) where - -#if defined(ASSERTS) -import Control.Exception (assert) -#endif - -data Size = Exact {-# UNPACK #-} !Int -- ^ Exact size. - | Max {-# UNPACK #-} !Int -- ^ Upper bound on size. - | Unknown -- ^ Unknown size. - deriving (Eq, Show) - -exactly :: Size -> Maybe Int -exactly (Exact n) = Just n -exactly _ = Nothing -{-# INLINE exactly #-} - -exactSize :: Int -> Size -exactSize n = -#if defined(ASSERTS) - assert (n >= 0) -#endif - Exact n -{-# INLINE exactSize #-} - -maxSize :: Int -> Size -maxSize n = -#if defined(ASSERTS) - assert (n >= 0) -#endif - Max n -{-# INLINE maxSize #-} - -unknownSize :: Size -unknownSize = Unknown -{-# INLINE unknownSize #-} - -instance Num Size where - (+) = addSize - (-) = subtractSize - (*) = mulSize - - fromInteger = f where f = Exact . fromInteger - {-# INLINE f #-} - -add :: Int -> Int -> Int -add m n | mn >= 0 = mn - | otherwise = overflowError - where mn = m + n -{-# INLINE add #-} - -addSize :: Size -> Size -> Size -addSize (Exact m) (Exact n) = Exact (add m n) -addSize (Exact m) (Max n) = Max (add m n) -addSize (Max m) (Exact n) = Max (add m n) -addSize (Max m) (Max n) = Max (add m n) -addSize _ _ = Unknown -{-# INLINE addSize #-} - -subtractSize :: Size -> Size -> Size -subtractSize (Exact m) (Exact n) = Exact (max (m-n) 0) -subtractSize (Exact m) (Max _) = Max m -subtractSize (Max m) (Exact n) = Max (max (m-n) 0) -subtractSize a@(Max _) (Max _) = a -subtractSize a@(Max _) Unknown = a -subtractSize _ _ = Unknown -{-# INLINE subtractSize #-} - -mul :: Int -> Int -> Int -mul m n - | m <= maxBound `quot` n = m * n - | otherwise = overflowError -{-# INLINE mul #-} - -mulSize :: Size -> Size -> Size -mulSize (Exact m) (Exact n) = Exact (mul m n) -mulSize (Exact m) (Max n) = Max (mul m n) -mulSize (Max m) (Exact n) = Max (mul m n) -mulSize (Max m) (Max n) = Max (mul m n) -mulSize _ _ = Unknown -{-# INLINE mulSize #-} - --- | Minimum of two size hints. -smaller :: Size -> Size -> Size -smaller (Exact m) (Exact n) = Exact (m `min` n) -smaller (Exact m) (Max n) = Max (m `min` n) -smaller (Exact m) Unknown = Max m -smaller (Max m) (Exact n) = Max (m `min` n) -smaller (Max m) (Max n) = Max (m `min` n) -smaller a@(Max _) Unknown = a -smaller Unknown (Exact n) = Max n -smaller Unknown (Max n) = Max n -smaller Unknown Unknown = Unknown -{-# INLINE smaller #-} - --- | Maximum of two size hints. -larger :: Size -> Size -> Size -larger (Exact m) (Exact n) = Exact (m `max` n) -larger a@(Exact m) b@(Max n) | m >= n = a - | otherwise = b -larger a@(Max m) b@(Exact n) | n >= m = b - | otherwise = a -larger (Max m) (Max n) = Max (m `max` n) -larger _ _ = Unknown -{-# INLINE larger #-} - --- | Compute the maximum size from a size hint, if possible. -upperBound :: Int -> Size -> Int -upperBound _ (Exact n) = n -upperBound _ (Max n) = n -upperBound k _ = k -{-# INLINE upperBound #-} - -isEmpty :: Size -> Bool -isEmpty (Exact n) = n <= 0 -isEmpty (Max n) = n <= 0 -isEmpty _ = False -{-# INLINE isEmpty #-} - -overflowError :: Int -overflowError = error "Data.Text.Fusion.Size: size overflow" diff --git a/Data/Text/IO.hs b/Data/Text/IO.hs --- a/Data/Text/IO.hs +++ b/Data/Text/IO.hs @@ -50,9 +50,9 @@ import Control.Monad (liftM2, when) import Data.IORef (readIORef, writeIORef) import qualified Data.Text as T -import Data.Text.Fusion (stream) -import Data.Text.Fusion.Internal (Step(..), Stream(..)) -import Data.Text.IO.Internal (hGetLineWith, readChunk) +import Data.Text.Internal.Fusion (stream) +import Data.Text.Internal.Fusion.Types (Step(..), Stream(..)) +import Data.Text.Internal.IO (hGetLineWith, readChunk) import GHC.IO.Buffer (Buffer(..), BufferState(..), CharBufElem, CharBuffer, RawCharBuffer, emptyBuffer, isEmptyBuffer, newCharBuffer, writeCharBuf) diff --git a/Data/Text/IO/Internal.hs b/Data/Text/IO/Internal.hs deleted file mode 100644 --- a/Data/Text/IO/Internal.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, RecordWildCards #-} --- | --- Module : Data.Text.IO.Internal --- Copyright : (c) 2009, 2010 Bryan O'Sullivan, --- (c) 2009 Simon Marlow --- License : BSD-style --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : GHC --- --- Low-level support for text I\/O. - -module Data.Text.IO.Internal - ( - hGetLineWith - , readChunk - ) where - -import qualified Control.Exception as E -import Data.IORef (readIORef, writeIORef) -import Data.Text (Text) -import Data.Text.Fusion (unstream) -import Data.Text.Fusion.Internal (Step(..), Stream(..)) -import Data.Text.Fusion.Size (exactSize, maxSize) -import Data.Text.Unsafe (inlinePerformIO) -import Foreign.Storable (peekElemOff) -import GHC.IO.Buffer (Buffer(..), CharBuffer, RawCharBuffer, bufferAdjustL, - bufferElems, charSize, isEmptyBuffer, readCharBuf, - withRawBuffer, writeCharBuf) -import GHC.IO.Handle.Internals (ioe_EOF, readTextDevice, wantReadableHandle_) -import GHC.IO.Handle.Types (Handle__(..), Newline(..)) -import System.IO (Handle) -import System.IO.Error (isEOFError) -import qualified Data.Text as T - --- | Read a single line of input from a handle, constructing a list of --- decoded chunks as we go. When we're done, transform them into the --- destination type. -hGetLineWith :: ([Text] -> t) -> Handle -> IO t -hGetLineWith f h = wantReadableHandle_ "hGetLine" h go - where - go hh@Handle__{..} = readIORef haCharBuffer >>= fmap f . hGetLineLoop hh [] - -hGetLineLoop :: Handle__ -> [Text] -> CharBuffer -> IO [Text] -hGetLineLoop hh@Handle__{..} = go where - go ts buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } = do - let findEOL raw r | r == w = return (False, w) - | otherwise = do - (c,r') <- readCharBuf raw r - if c == '\n' - then return (True, r) - else findEOL raw r' - (eol, off) <- findEOL raw0 r0 - (t,r') <- if haInputNL == CRLF - then unpack_nl raw0 r0 off - else do t <- unpack raw0 r0 off - return (t,off) - if eol - then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf) - return $ reverse (t:ts) - else do - let buf1 = bufferAdjustL r' buf - maybe_buf <- maybeFillReadBuffer hh buf1 - case maybe_buf of - -- Nothing indicates we caught an EOF, and we may have a - -- partial line to return. - Nothing -> do - -- we reached EOF. There might be a lone \r left - -- in the buffer, so check for that and - -- append it to the line if necessary. - let pre | isEmptyBuffer buf1 = T.empty - | otherwise = T.singleton '\r' - writeIORef haCharBuffer buf1{ bufL=0, bufR=0 } - let str = reverse . filter (not . T.null) $ pre:t:ts - if null str - then ioe_EOF - else return str - Just new_buf -> go (t:ts) new_buf - --- This function is lifted almost verbatim from GHC.IO.Handle.Text. -maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer) -maybeFillReadBuffer handle_ buf - = E.catch (Just `fmap` getSomeCharacters handle_ buf) $ \e -> - if isEOFError e - then return Nothing - else ioError e - -unpack :: RawCharBuffer -> Int -> Int -> IO Text -unpack !buf !r !w - | charSize /= 4 = sizeError "unpack" - | r >= w = return T.empty - | otherwise = withRawBuffer buf go - where - go pbuf = return $! unstream (Stream next r (exactSize (w-r))) - where - next !i | i >= w = Done - | otherwise = Yield (ix i) (i+1) - ix i = inlinePerformIO $ peekElemOff pbuf i - -unpack_nl :: RawCharBuffer -> Int -> Int -> IO (Text, Int) -unpack_nl !buf !r !w - | charSize /= 4 = sizeError "unpack_nl" - | r >= w = return (T.empty, 0) - | otherwise = withRawBuffer buf $ go - where - go pbuf = do - let !t = unstream (Stream next r (maxSize (w-r))) - w' = w - 1 - return $ if ix w' == '\r' - then (t,w') - else (t,w) - where - next !i | i >= w = Done - | c == '\r' = let i' = i + 1 - in if i' < w - then if ix i' == '\n' - then Yield '\n' (i+2) - else Yield '\n' i' - else Done - | otherwise = Yield c (i+1) - where c = ix i - ix i = inlinePerformIO $ peekElemOff pbuf i - --- This function is completely lifted from GHC.IO.Handle.Text. -getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer -getSomeCharacters handle_@Handle__{..} buf@Buffer{..} = - case bufferElems buf of - -- buffer empty: read some more - 0 -> {-# SCC "readTextDevice" #-} readTextDevice handle_ buf - - -- if the buffer has a single '\r' in it and we're doing newline - -- translation: read some more - 1 | haInputNL == CRLF -> do - (c,_) <- readCharBuf bufRaw bufL - if c == '\r' - then do -- shuffle the '\r' to the beginning. This is only safe - -- if we're about to call readTextDevice, otherwise it - -- would mess up flushCharBuffer. - -- See [note Buffer Flushing], GHC.IO.Handle.Types - _ <- writeCharBuf bufRaw 0 '\r' - let buf' = buf{ bufL=0, bufR=1 } - readTextDevice handle_ buf' - else do - return buf - - -- buffer has some chars in it already: just return it - _otherwise -> {-# SCC "otherwise" #-} return buf - --- | Read a single chunk of strict text from a buffer. Used by both --- the strict and lazy implementations of hGetContents. -readChunk :: Handle__ -> CharBuffer -> IO Text -readChunk hh@Handle__{..} buf = do - buf'@Buffer{..} <- getSomeCharacters hh buf - (t,r) <- if haInputNL == CRLF - then unpack_nl bufRaw bufL bufR - else do t <- unpack bufRaw bufL bufR - return (t,bufR) - writeIORef haCharBuffer (bufferAdjustL r buf') - return t - -sizeError :: String -> a -sizeError loc = error $ "Data.Text.IO." ++ loc ++ ": bad internal buffer size" diff --git a/Data/Text/Internal.hs b/Data/Text/Internal.hs --- a/Data/Text/Internal.hs +++ b/Data/Text/Internal.hs @@ -7,8 +7,7 @@ -- (c) 2009 Duncan Coutts -- -- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org +-- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- @@ -43,7 +42,7 @@ #endif import Data.Bits ((.&.)) import qualified Data.Text.Array as A -import Data.Text.UnsafeChar (ord) +import Data.Text.Internal.Unsafe.Char (ord) import Data.Typeable (Typeable) -- | A space efficient, packed, unboxed Unicode text type. diff --git a/Data/Text/Internal/Builder.hs b/Data/Text/Internal/Builder.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Builder.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE BangPatterns, CPP, Rank2Types #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Text.Internal.Builder +-- Copyright : (c) 2013 Bryan O'Sullivan +-- (c) 2010 Johan Tibell +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Johan Tibell +-- Stability : experimental +-- Portability : portable to Hugs and GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Efficient construction of lazy @Text@ values. The principal +-- operations on a @Builder@ are @singleton@, @fromText@, and +-- @fromLazyText@, which construct new builders, and 'mappend', which +-- concatenates two builders. +-- +-- To get maximum performance when building lazy @Text@ values using a +-- builder, associate @mappend@ calls to the right. For example, +-- prefer +-- +-- > singleton 'a' `mappend` (singleton 'b' `mappend` singleton 'c') +-- +-- to +-- +-- > singleton 'a' `mappend` singleton 'b' `mappend` singleton 'c' +-- +-- as the latter associates @mappend@ to the left. +-- +----------------------------------------------------------------------------- + +module Data.Text.Internal.Builder + ( -- * Public API + -- ** The Builder type + Builder + , toLazyText + , toLazyTextWith + + -- ** Constructing Builders + , singleton + , fromText + , fromLazyText + , fromString + + -- ** Flushing the buffer state + , flush + + -- * Internal functions + , append' + , ensureFree + , writeN + ) where + +import Control.Monad.ST (ST, runST) +import Data.Bits ((.&.)) +import Data.Monoid (Monoid(..)) +import Data.Text.Internal (Text(..)) +import Data.Text.Internal.Lazy (smallChunkSize) +import Data.Text.Unsafe (inlineInterleaveST) +import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite) +import Data.Text.Internal.Unsafe.Shift (shiftR) +import Prelude hiding (map, putChar) + +import qualified Data.String as String +import qualified Data.Text as S +import qualified Data.Text.Array as A +import qualified Data.Text.Lazy as L + +------------------------------------------------------------------------ + +-- | A @Builder@ is an efficient way to build lazy @Text@ values. +-- There are several functions for constructing builders, but only one +-- to inspect them: to extract any data, you have to turn them into +-- lazy @Text@ values using @toLazyText@. +-- +-- Internally, a builder constructs a lazy @Text@ by filling arrays +-- piece by piece. As each buffer is filled, it is \'popped\' off, to +-- become a new chunk of the resulting lazy @Text@. All this is +-- hidden from the user of the @Builder@. +newtype Builder = Builder { + -- Invariant (from Data.Text.Lazy): + -- The lists include no null Texts. + runBuilder :: forall s. (Buffer s -> ST s [S.Text]) + -> Buffer s + -> ST s [S.Text] + } + +instance Monoid Builder where + mempty = empty + {-# INLINE mempty #-} + mappend = append + {-# INLINE mappend #-} + mconcat = foldr mappend mempty + {-# INLINE mconcat #-} + +instance String.IsString Builder where + fromString = fromString + {-# INLINE fromString #-} + +instance Show Builder where + show = show . toLazyText + +instance Eq Builder where + a == b = toLazyText a == toLazyText b + +instance Ord Builder where + a <= b = toLazyText a <= toLazyText b + +------------------------------------------------------------------------ + +-- | /O(1)./ The empty @Builder@, satisfying +-- +-- * @'toLazyText' 'empty' = 'L.empty'@ +-- +empty :: Builder +empty = Builder (\ k buf -> k buf) +{-# INLINE empty #-} + +-- | /O(1)./ A @Builder@ taking a single character, satisfying +-- +-- * @'toLazyText' ('singleton' c) = 'L.singleton' c@ +-- +singleton :: Char -> Builder +singleton c = writeAtMost 2 $ \ marr o -> + if n < 0x10000 + then A.unsafeWrite marr o (fromIntegral n) >> return 1 + else do + A.unsafeWrite marr o lo + A.unsafeWrite marr (o+1) hi + return 2 + where n = ord c + m = n - 0x10000 + lo = fromIntegral $ (m `shiftR` 10) + 0xD800 + hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00 +{-# INLINE singleton #-} + +------------------------------------------------------------------------ + +-- | /O(1)./ The concatenation of two builders, an associative +-- operation with identity 'empty', satisfying +-- +-- * @'toLazyText' ('append' x y) = 'L.append' ('toLazyText' x) ('toLazyText' y)@ +-- +append :: Builder -> Builder -> Builder +append (Builder f) (Builder g) = Builder (f . g) +{-# INLINE [0] append #-} + +-- TODO: Experiment to find the right threshold. +copyLimit :: Int +copyLimit = 128 + +-- This function attempts to merge small @Text@ values instead of +-- treating each value as its own chunk. We may not always want this. + +-- | /O(1)./ A @Builder@ taking a 'S.Text', satisfying +-- +-- * @'toLazyText' ('fromText' t) = 'L.fromChunks' [t]@ +-- +fromText :: S.Text -> Builder +fromText t@(Text arr off l) + | S.null t = empty + | l <= copyLimit = writeN l $ \marr o -> A.copyI marr o arr off (l+o) + | otherwise = flush `append` mapBuilder (t :) +{-# INLINE [1] fromText #-} + +{-# RULES +"fromText/pack" forall s . + fromText (S.pack s) = fromString s + #-} + +-- | /O(1)./ A Builder taking a @String@, satisfying +-- +-- * @'toLazyText' ('fromString' s) = 'L.fromChunks' [S.pack s]@ +-- +fromString :: String -> Builder +fromString str = Builder $ \k (Buffer p0 o0 u0 l0) -> + let loop !marr !o !u !l [] = k (Buffer marr o u l) + loop marr o u l s@(c:cs) + | l <= 1 = do + arr <- A.unsafeFreeze marr + let !t = Text arr o u + marr' <- A.new chunkSize + ts <- inlineInterleaveST (loop marr' 0 0 chunkSize s) + return $ t : ts + | otherwise = do + n <- unsafeWrite marr (o+u) c + loop marr o (u+n) (l-n) cs + in loop p0 o0 u0 l0 str + where + chunkSize = smallChunkSize +{-# INLINE fromString #-} + +-- | /O(1)./ A @Builder@ taking a lazy @Text@, satisfying +-- +-- * @'toLazyText' ('fromLazyText' t) = t@ +-- +fromLazyText :: L.Text -> Builder +fromLazyText ts = flush `append` mapBuilder (L.toChunks ts ++) +{-# INLINE fromLazyText #-} + +------------------------------------------------------------------------ + +-- Our internal buffer type +data Buffer s = Buffer {-# UNPACK #-} !(A.MArray s) + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- used units + {-# UNPACK #-} !Int -- length left + +------------------------------------------------------------------------ + +-- | /O(n)./ Extract a lazy @Text@ from a @Builder@ with a default +-- buffer size. The construction work takes place if and when the +-- relevant part of the lazy @Text@ is demanded. +toLazyText :: Builder -> L.Text +toLazyText = toLazyTextWith smallChunkSize + +-- | /O(n)./ Extract a lazy @Text@ from a @Builder@, using the given +-- size for the initial buffer. The construction work takes place if +-- and when the relevant part of the lazy @Text@ is demanded. +-- +-- If the initial buffer is too small to hold all data, subsequent +-- buffers will be the default buffer size. +toLazyTextWith :: Int -> Builder -> L.Text +toLazyTextWith chunkSize m = L.fromChunks (runST $ + newBuffer chunkSize >>= runBuilder (m `append` flush) (const (return []))) + +-- | /O(1)./ Pop the strict @Text@ we have constructed so far, if any, +-- yielding a new chunk in the result lazy @Text@. +flush :: Builder +flush = Builder $ \ k buf@(Buffer p o u l) -> + if u == 0 + then k buf + else do arr <- A.unsafeFreeze p + let !b = Buffer p (o+u) 0 l + !t = Text arr o u + ts <- inlineInterleaveST (k b) + return $! t : ts + +------------------------------------------------------------------------ + +-- | Sequence an ST operation on the buffer +withBuffer :: (forall s. Buffer s -> ST s (Buffer s)) -> Builder +withBuffer f = Builder $ \k buf -> f buf >>= k +{-# INLINE withBuffer #-} + +-- | Get the size of the buffer +withSize :: (Int -> Builder) -> Builder +withSize f = Builder $ \ k buf@(Buffer _ _ _ l) -> + runBuilder (f l) k buf +{-# INLINE withSize #-} + +-- | Map the resulting list of texts. +mapBuilder :: ([S.Text] -> [S.Text]) -> Builder +mapBuilder f = Builder (fmap f .) + +------------------------------------------------------------------------ + +-- | Ensure that there are at least @n@ many elements available. +ensureFree :: Int -> Builder +ensureFree !n = withSize $ \ l -> + if n <= l + then empty + else flush `append'` withBuffer (const (newBuffer (max n smallChunkSize))) +{-# INLINE [0] ensureFree #-} + +writeAtMost :: Int -> (forall s. A.MArray s -> Int -> ST s Int) -> Builder +writeAtMost n f = ensureFree n `append'` withBuffer (writeBuffer f) +{-# INLINE [0] writeAtMost #-} + +-- | Ensure that @n@ many elements are available, and then use @f@ to +-- write some elements into the memory. +writeN :: Int -> (forall s. A.MArray s -> Int -> ST s ()) -> Builder +writeN n f = writeAtMost n (\ p o -> f p o >> return n) +{-# INLINE writeN #-} + +writeBuffer :: (A.MArray s -> Int -> ST s Int) -> Buffer s -> ST s (Buffer s) +writeBuffer f (Buffer p o u l) = do + n <- f p (o+u) + return $! Buffer p o (u+n) (l-n) +{-# INLINE writeBuffer #-} + +newBuffer :: Int -> ST s (Buffer s) +newBuffer size = do + arr <- A.new size + return $! Buffer arr 0 0 size +{-# INLINE newBuffer #-} + +------------------------------------------------------------------------ +-- Some nice rules for Builder + +-- This function makes GHC understand that 'writeN' and 'ensureFree' +-- are *not* recursive in the precense of the rewrite rules below. +-- This is not needed with GHC 7+. +append' :: Builder -> Builder -> Builder +append' (Builder f) (Builder g) = Builder (f . g) +{-# INLINE append' #-} + +{-# RULES + +"append/writeAtMost" forall a b (f::forall s. A.MArray s -> Int -> ST s Int) + (g::forall s. A.MArray s -> Int -> ST s Int) ws. + append (writeAtMost a f) (append (writeAtMost b g) ws) = + append (writeAtMost (a+b) (\marr o -> f marr o >>= \ n -> + g marr (o+n) >>= \ m -> + let s = n+m in s `seq` return s)) ws + +"writeAtMost/writeAtMost" forall a b (f::forall s. A.MArray s -> Int -> ST s Int) + (g::forall s. A.MArray s -> Int -> ST s Int). + append (writeAtMost a f) (writeAtMost b g) = + writeAtMost (a+b) (\marr o -> f marr o >>= \ n -> + g marr (o+n) >>= \ m -> + let s = n+m in s `seq` return s) + +"ensureFree/ensureFree" forall a b . + append (ensureFree a) (ensureFree b) = ensureFree (max a b) + +"flush/flush" + append flush flush = flush + + #-} diff --git a/Data/Text/Internal/Builder/Functions.hs b/Data/Text/Internal/Builder/Functions.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Builder/Functions.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE MagicHash #-} + +-- | +-- Module : Data.Text.Internal.Builder.Functions +-- Copyright : (c) 2011 MailRank, Inc. +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Useful functions and combinators. + +module Data.Text.Internal.Builder.Functions + ( + (<>) + , i2d + ) where + +import Data.Monoid (mappend) +import Data.Text.Lazy.Builder (Builder) +import GHC.Base + +-- | Unsafe conversion for decimal digits. +{-# INLINE i2d #-} +i2d :: Int -> Char +i2d (I# i#) = C# (chr# (ord# '0'# +# i#)) + +-- | The normal 'mappend' function with right associativity instead of +-- left. +(<>) :: Builder -> Builder -> Builder +(<>) = mappend +{-# INLINE (<>) #-} + +infixr 4 <> diff --git a/Data/Text/Internal/Builder/Int/Digits.hs b/Data/Text/Internal/Builder/Int/Digits.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Builder/Int/Digits.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Module: Data.Text.Internal.Builder.Int.Digits +-- Copyright: (c) 2013 Bryan O'Sullivan +-- License: BSD3 +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- This module exists because the C preprocessor does things that we +-- shall not speak of when confronted with Haskell multiline strings. + +module Data.Text.Internal.Builder.Int.Digits (digits) where + +import Data.ByteString.Char8 (ByteString) + +digits :: ByteString +digits = "0001020304050607080910111213141516171819\ + \2021222324252627282930313233343536373839\ + \4041424344454647484950515253545556575859\ + \6061626364656667686970717273747576777879\ + \8081828384858687888990919293949596979899" diff --git a/Data/Text/Internal/Builder/RealFloat/Functions.hs b/Data/Text/Internal/Builder/RealFloat/Functions.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Builder/RealFloat/Functions.hs @@ -0,0 +1,29 @@ +-- | +-- Module: Data.Text.Internal.Builder.RealFloat.Functions +-- Copyright: (c) The University of Glasgow 1994-2002 +-- License: see libraries/base/LICENSE +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! + +module Data.Text.Internal.Builder.RealFloat.Functions + ( + roundTo + ) where + +roundTo :: Int -> [Int] -> (Int,[Int]) +roundTo d is = + case f d is of + x@(0,_) -> x + (1,xs) -> (1, 1:xs) + _ -> error "roundTo: bad Value" + where + f n [] = (0, replicate n 0) + f 0 (x:_) = (if x >= 5 then 1 else 0, []) + f n (i:xs) + | i' == 10 = (1,0:ds) + | otherwise = (0,i':ds) + where + (c,ds) = f (n-1) xs + i' = c + i diff --git a/Data/Text/Internal/Encoding/Fusion.hs b/Data/Text/Internal/Encoding/Fusion.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Encoding/Fusion.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE BangPatterns, CPP, Rank2Types #-} + +-- | +-- Module : Data.Text.Internal.Encoding.Fusion +-- Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : portable +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Fusible 'Stream'-oriented functions for converting between 'Text' +-- and several common encodings. + +module Data.Text.Internal.Encoding.Fusion + ( + -- * Streaming + streamASCII + , streamUtf8 + , streamUtf16LE + , streamUtf16BE + , streamUtf32LE + , streamUtf32BE + + -- * Unstreaming + , unstream + + , module Data.Text.Internal.Encoding.Fusion.Common + ) where + +#if defined(ASSERTS) +import Control.Exception (assert) +#endif +import Data.ByteString.Internal (ByteString(..), mallocByteString, memcpy) +import Data.Text.Internal.Fusion (Step(..), Stream(..)) +import Data.Text.Internal.Fusion.Size +import Data.Text.Encoding.Error +import Data.Text.Internal.Encoding.Fusion.Common +import Data.Text.Internal.Unsafe.Char (unsafeChr, unsafeChr8, unsafeChr32) +import Data.Text.Internal.Unsafe.Shift (shiftL, shiftR) +import Data.Word (Word8, Word16, Word32) +import Foreign.ForeignPtr (withForeignPtr, ForeignPtr) +import Foreign.Storable (pokeByteOff) +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.Text.Internal.Encoding.Utf8 as U8 +import qualified Data.Text.Internal.Encoding.Utf16 as U16 +import qualified Data.Text.Internal.Encoding.Utf32 as U32 +import Data.Text.Unsafe (unsafeDupablePerformIO) + +streamASCII :: ByteString -> Stream Char +streamASCII bs = Stream next 0 (maxSize 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 +{-# DEPRECATED streamASCII "Do not use this function" #-} +{-# INLINE [0] streamASCII #-} + +-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using UTF-8 +-- encoding. +streamUtf8 :: OnDecodeError -> ByteString -> Stream Char +streamUtf8 onErr bs = Stream next 0 (maxSize l) + where + l = B.length bs + 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 = decodeError "streamUtf8" "UTF-8" onErr (Just x1) (i+1) + 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 :: OnDecodeError -> ByteString -> Stream Char +streamUtf16LE onErr bs = Stream next 0 (maxSize (l `shiftR` 1)) + 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 = decodeError "streamUtf16LE" "UTF-16LE" onErr Nothing (i+1) + 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 :: OnDecodeError -> ByteString -> Stream Char +streamUtf16BE onErr bs = Stream next 0 (maxSize (l `shiftR` 1)) + 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 = decodeError "streamUtf16BE" "UTF-16BE" onErr Nothing (i+1) + 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 :: OnDecodeError -> ByteString -> Stream Char +streamUtf32BE onErr bs = Stream next 0 (maxSize (l `shiftR` 2)) + where + l = B.length bs + {-# INLINE next #-} + next i + | i >= l = Done + | i+3 < l && U32.validate x = Yield (unsafeChr32 x) (i+4) + | otherwise = decodeError "streamUtf32BE" "UTF-32BE" onErr Nothing (i+1) + 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 :: OnDecodeError -> ByteString -> Stream Char +streamUtf32LE onErr bs = Stream next 0 (maxSize (l `shiftR` 2)) + where + l = B.length bs + {-# INLINE next #-} + next i + | i >= l = Done + | i+3 < l && U32.validate x = Yield (unsafeChr32 x) (i+4) + | otherwise = decodeError "streamUtf32LE" "UTF-32LE" onErr Nothing (i+1) + 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' 'Word8' to a 'ByteString'. +unstream :: Stream Word8 -> ByteString +unstream (Stream next s0 len) = unsafeDupablePerformIO $ do + let mlen = upperBound 4 len + mallocByteString mlen >>= loop mlen 0 s0 + where + loop !n !off !s fp = case next s of + Done -> trimUp fp n off + Skip s' -> loop n off s' fp + Yield x s' + | off == n -> realloc fp n off s' x + | otherwise -> do + withForeignPtr fp $ \p -> pokeByteOff p off x + loop n (off+1) s' fp + {-# NOINLINE realloc #-} + realloc fp n off s x = do + let n' = n+n + fp' <- copy0 fp n n' + withForeignPtr fp' $ \p -> pokeByteOff p off x + loop n' (off+1) s fp' + {-# NOINLINE trimUp #-} + trimUp fp _ off = return $! PS fp 0 off + copy0 :: ForeignPtr Word8 -> Int -> Int -> IO (ForeignPtr Word8) + copy0 !src !srcLen !destLen = +#if defined(ASSERTS) + assert (srcLen <= destLen) $ +#endif + do + dest <- mallocByteString destLen + withForeignPtr src $ \src' -> + withForeignPtr dest $ \dest' -> + memcpy dest' src' (fromIntegral srcLen) + return dest + +decodeError :: forall s. String -> String -> OnDecodeError -> Maybe Word8 + -> s -> Step s Char +decodeError func kind onErr mb i = + case onErr desc mb of + Nothing -> Skip i + Just c -> Yield c i + where desc = "Data.Text.Internal.Encoding.Fusion." ++ func ++ ": Invalid " ++ + kind ++ " stream" diff --git a/Data/Text/Internal/Encoding/Fusion/Common.hs b/Data/Text/Internal/Encoding/Fusion/Common.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Encoding/Fusion/Common.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Data.Text.Internal.Encoding.Fusion.Common +-- Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009, +-- (c) Jasper Van der Jeugt 2011 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : portable +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Use at your own risk! +-- +-- Fusible 'Stream'-oriented functions for converting between 'Text' +-- and several common encodings. + +module Data.Text.Internal.Encoding.Fusion.Common + ( + -- * Restreaming + -- Restreaming is the act of converting from one 'Stream' + -- representation to another. + restreamUtf16LE + , restreamUtf16BE + , restreamUtf32LE + , restreamUtf32BE + ) where + +import Data.Bits ((.&.)) +import Data.Text.Internal.Fusion (Step(..), Stream(..)) +import Data.Text.Internal.Fusion.Types (RS(..)) +import Data.Text.Internal.Unsafe.Char (ord) +import Data.Text.Internal.Unsafe.Shift (shiftR) +import Data.Word (Word8) + +restreamUtf16BE :: Stream Char -> Stream Word8 +restreamUtf16BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2) + where + next (RS0 s) = case next0 s of + Done -> Done + Skip s' -> Skip (RS0 s') + Yield x s' + | n < 0x10000 -> Yield (fromIntegral $ n `shiftR` 8) $ + RS1 s' (fromIntegral n) + | otherwise -> Yield c1 $ RS3 s' c2 c3 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 (RS1 s x2) = Yield x2 (RS0 s) + next (RS2 s x2 x3) = Yield x2 (RS1 s x3) + next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4) + {-# INLINE next #-} +{-# INLINE restreamUtf16BE #-} + +restreamUtf16LE :: Stream Char -> Stream Word8 +restreamUtf16LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2) + where + next (RS0 s) = case next0 s of + Done -> Done + Skip s' -> Skip (RS0 s') + Yield x s' + | n < 0x10000 -> Yield (fromIntegral n) $ + RS1 s' (fromIntegral $ shiftR n 8) + | otherwise -> Yield c1 $ RS3 s' c2 c3 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 (RS1 s x2) = Yield x2 (RS0 s) + next (RS2 s x2 x3) = Yield x2 (RS1 s x3) + next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4) + {-# INLINE next #-} +{-# INLINE restreamUtf16LE #-} + +restreamUtf32BE :: Stream Char -> Stream Word8 +restreamUtf32BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2) + where + next (RS0 s) = case next0 s of + Done -> Done + Skip s' -> Skip (RS0 s') + Yield x s' -> Yield c1 (RS3 s' c2 c3 c4) + where + n = ord x + c1 = fromIntegral $ shiftR n 24 + c2 = fromIntegral $ shiftR n 16 + c3 = fromIntegral $ shiftR n 8 + c4 = fromIntegral n + next (RS1 s x2) = Yield x2 (RS0 s) + next (RS2 s x2 x3) = Yield x2 (RS1 s x3) + next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4) + {-# INLINE next #-} +{-# INLINE restreamUtf32BE #-} + +restreamUtf32LE :: Stream Char -> Stream Word8 +restreamUtf32LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2) + where + next (RS0 s) = case next0 s of + Done -> Done + Skip s' -> Skip (RS0 s') + Yield x s' -> Yield c1 (RS3 s' c2 c3 c4) + where + n = ord x + c4 = fromIntegral $ shiftR n 24 + c3 = fromIntegral $ shiftR n 16 + c2 = fromIntegral $ shiftR n 8 + c1 = fromIntegral n + next (RS1 s x2) = Yield x2 (RS0 s) + next (RS2 s x2 x3) = Yield x2 (RS1 s x3) + next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4) + {-# INLINE next #-} +{-# INLINE restreamUtf32LE #-} diff --git a/Data/Text/Internal/Encoding/Utf16.hs b/Data/Text/Internal/Encoding/Utf16.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Encoding/Utf16.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE MagicHash, BangPatterns #-} + +-- | +-- Module : Data.Text.Internal.Encoding.Utf16 +-- Copyright : (c) 2008, 2009 Tom Harper, +-- (c) 2009 Bryan O'Sullivan, +-- (c) 2009 Duncan Coutts +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Basic UTF-16 validation and character manipulation. +module Data.Text.Internal.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 < 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/Internal/Encoding/Utf32.hs b/Data/Text/Internal/Encoding/Utf32.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Encoding/Utf32.hs @@ -0,0 +1,26 @@ +-- | +-- Module : Data.Text.Internal.Encoding.Utf32 +-- Copyright : (c) 2008, 2009 Tom Harper, +-- (c) 2009, 2010 Bryan O'Sullivan, +-- (c) 2009 Duncan Coutts +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : portable +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Basic UTF-32 validation. +module Data.Text.Internal.Encoding.Utf32 + ( + validate + ) where + +import Data.Word (Word32) + +validate :: Word32 -> Bool +validate x1 = x1 < 0xD800 || (x1 > 0xDFFF && x1 <= 0x10FFFF) +{-# INLINE validate #-} diff --git a/Data/Text/Internal/Encoding/Utf8.hs b/Data/Text/Internal/Encoding/Utf8.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Encoding/Utf8.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE CPP, MagicHash, BangPatterns #-} + +-- | +-- Module : Data.Text.Internal.Encoding.Utf8 +-- Copyright : (c) 2008, 2009 Tom Harper, +-- (c) 2009, 2010 Bryan O'Sullivan, +-- (c) 2009 Duncan Coutts +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Basic UTF-8 validation and character manipulation. +module Data.Text.Internal.Encoding.Utf8 + ( + -- Decomposition + ord2 + , ord3 + , ord4 + -- Construction + , chr2 + , chr3 + , chr4 + -- * Validation + , validate1 + , validate2 + , validate3 + , validate4 + ) where + +#if defined(TEST_SUITE) +# undef ASSERTS +#endif + +#if defined(ASSERTS) +import Control.Exception (assert) +#endif +import Data.Bits ((.&.)) +import Data.Text.Internal.Unsafe.Char (ord) +import Data.Text.Internal.Unsafe.Shift (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 = +#if defined(ASSERTS) + assert (n >= 0x80 && n <= 0x07ff) +#endif + (x1,x2) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 6) + 0xC0 + x2 = fromIntegral $ (n .&. 0x3F) + 0x80 + +ord3 :: Char -> (Word8,Word8,Word8) +ord3 c = +#if defined(ASSERTS) + assert (n >= 0x0800 && n <= 0xffff) +#endif + (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 = +#if defined(ASSERTS) + assert (n >= 0x10000) +#endif + (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 = x1 <= 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/Internal/Functions.hs b/Data/Text/Internal/Functions.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Functions.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +-- | +-- Module : Data.Text.Internal.Functions +-- Copyright : 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Useful functions. + +module Data.Text.Internal.Functions + ( + intersperse + ) where + +-- | A lazier version of Data.List.intersperse. The other version +-- causes space leaks! +intersperse :: a -> [a] -> [a] +intersperse _ [] = [] +intersperse sep (x:xs) = x : go xs + where + go [] = [] + go (y:ys) = sep : y: go ys +{-# INLINE intersperse #-} diff --git a/Data/Text/Internal/Fusion.hs b/Data/Text/Internal/Fusion.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Fusion.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE BangPatterns, MagicHash #-} + +-- | +-- Module : Data.Text.Internal.Fusion +-- Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009-2010, +-- (c) Duncan Coutts 2009 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Text manipulation functions represented as fusible operations over +-- streams. +module Data.Text.Internal.Fusion + ( + -- * Types + Stream(..) + , Step(..) + + -- * Creation and elimination + , stream + , unstream + , reverseStream + + , length + + -- * Transformations + , reverse + + -- * Construction + -- ** Scans + , reverseScanr + + -- ** Accumulating maps + , mapAccumL + + -- ** Generation and unfolding + , unfoldrN + + -- * Indexing + , index + , findIndex + , countChar + ) where + +import Prelude (Bool(..), Char, Maybe(..), Monad(..), Int, + Num(..), Ord(..), ($), (&&), + fromIntegral, otherwise) +import Data.Bits ((.&.)) +import Data.Text.Internal (Text(..)) +import Data.Text.Internal.Private (runText) +import Data.Text.Internal.Unsafe.Char (ord, unsafeChr, unsafeWrite) +import Data.Text.Internal.Unsafe.Shift (shiftL, shiftR) +import qualified Data.Text.Array as A +import qualified Data.Text.Internal.Fusion.Common as S +import Data.Text.Internal.Fusion.Types +import Data.Text.Internal.Fusion.Size +import qualified Data.Text.Internal as I +import qualified Data.Text.Internal.Encoding.Utf16 as U16 + +default(Int) + +-- | /O(n)/ Convert a 'Text' into a 'Stream Char'. +stream :: Text -> Stream Char +stream (Text arr off len) = Stream next off (maxSize len) + where + !end = off+len + 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) (maxSize 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) = runText $ \done -> do + let mlen = upperBound 4 len + arr0 <- A.new mlen + let outer arr top = loop + where + loop !s !i = + case next0 s of + Done -> done arr i + Skip s' -> loop s' i + Yield x s' + | j >= top -> {-# SCC "unstream/resize" #-} do + let top' = (top + 1) `shiftL` 1 + arr' <- A.new top' + A.copyM arr' 0 arr 0 top + outer arr' top' s i + | otherwise -> do d <- unsafeWrite arr i x + loop s' (i+d) + where j | ord x < 0x10000 = i + | otherwise = i + 1 + outer arr0 mlen s0 0 +{-# INLINE [0] unstream #-} +{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-} + + +-- ---------------------------------------------------------------------------- +-- * Basic stream functions + +length :: Stream Char -> Int +length = S.lengthI +{-# INLINE[0] length #-} + +-- | /O(n)/ Reverse the characters of a string. +reverse :: Stream Char -> Text +reverse (Stream next s len0) + | isEmpty len0 = I.empty + | otherwise = I.textP arr off' len' + where + len0' = upperBound 4 (larger len0 4) + (arr, (off', len')) = A.run2 (A.new 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 -> {-# SCC "reverse/resize" #-} do + let newLen = len `shiftL` 1 + marr' <- A.new newLen + A.copyM marr' (newLen-len) marr 0 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 t j l mar + | n < 0x10000 = do + A.unsafeWrite mar j (fromIntegral n) + loop t (j-1) l mar + | otherwise = do + A.unsafeWrite mar (j-1) lo + A.unsafeWrite mar j hi + loop t (j-2) l mar +{-# INLINE [0] reverse #-} + +-- | /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) -- HINT maybe too low + where + {-# INLINE next #-} + next (S1 :*: z :*: s) = Yield z (S2 :*: z :*: s) + next (S2 :*: z :*: s) = case next0 s of + Yield x s' -> let !x' = f x z + in Yield x' (S2 :*: x' :*: s') + Skip s' -> Skip (S2 :*: z :*: s') + Done -> Done +{-# INLINE reverseScanr #-} + +-- | /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 = S.unfoldrNI n +{-# INLINE [0] unfoldrN #-} + +------------------------------------------------------------------------------- +-- ** Indexing streams + +-- | /O(n)/ stream index (subscript) operator, starting from 0. +index :: Stream Char -> Int -> Char +index = S.indexI +{-# INLINE [0] index #-} + +-- | The 'findIndex' function takes a predicate and a stream and +-- returns the index of the first element in the stream +-- satisfying the predicate. +findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int +findIndex = S.findIndexI +{-# INLINE [0] findIndex #-} + +-- | /O(n)/ The 'count' function returns the number of times the query +-- element appears in the given stream. +countChar :: Char -> Stream Char -> Int +countChar = S.countCharI +{-# INLINE [0] countChar #-} + +-- | /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 -> Stream Char -> (a, Text) +mapAccumL f z0 (Stream next0 s0 len) = (nz,I.textP na 0 nl) + where + (na,(nz,nl)) = A.run2 (A.new mlen >>= \arr -> outer arr mlen z0 s0 0) + where mlen = upperBound 4 len + outer arr top = loop + where + loop !z !s !i = + case next0 s of + Done -> return (arr, (z,i)) + Skip s' -> loop z s' i + Yield x s' + | j >= top -> {-# SCC "mapAccumL/resize" #-} do + let top' = (top + 1) `shiftL` 1 + arr' <- A.new top' + A.copyM arr' 0 arr 0 top + outer arr' top' z s i + | otherwise -> do d <- unsafeWrite arr i c + loop z' s' (i+d) + where (z',c) = f z x + j | ord c < 0x10000 = i + | otherwise = i + 1 +{-# INLINE [0] mapAccumL #-} diff --git a/Data/Text/Internal/Fusion/CaseMapping.hs b/Data/Text/Internal/Fusion/CaseMapping.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Fusion/CaseMapping.hs @@ -0,0 +1,570 @@ +{-# LANGUAGE Rank2Types #-} +-- AUTOMATICALLY GENERATED - DO NOT EDIT +-- Generated by scripts/SpecialCasing.hs +-- CaseFolding-6.3.0.txt +-- Date: 2012-12-20, 22:14:35 GMT [MD] +-- SpecialCasing-6.3.0.txt +-- Date: 2013-05-08, 13:54:51 GMT [MD] + +module Data.Text.Internal.Fusion.CaseMapping where +import Data.Char +import Data.Text.Internal.Fusion.Types + +upperMapping :: forall s. Char -> s -> Step (CC s) Char +{-# INLINE upperMapping #-} +-- LATIN SMALL LETTER SHARP S +upperMapping '\x00df' s = Yield '\x0053' (CC s '\x0053' '\x0000') +-- LATIN SMALL LIGATURE FF +upperMapping '\xfb00' s = Yield '\x0046' (CC s '\x0046' '\x0000') +-- LATIN SMALL LIGATURE FI +upperMapping '\xfb01' s = Yield '\x0046' (CC s '\x0049' '\x0000') +-- LATIN SMALL LIGATURE FL +upperMapping '\xfb02' s = Yield '\x0046' (CC s '\x004c' '\x0000') +-- LATIN SMALL LIGATURE FFI +upperMapping '\xfb03' s = Yield '\x0046' (CC s '\x0046' '\x0049') +-- LATIN SMALL LIGATURE FFL +upperMapping '\xfb04' s = Yield '\x0046' (CC s '\x0046' '\x004c') +-- LATIN SMALL LIGATURE LONG S T +upperMapping '\xfb05' s = Yield '\x0053' (CC s '\x0054' '\x0000') +-- LATIN SMALL LIGATURE ST +upperMapping '\xfb06' s = Yield '\x0053' (CC s '\x0054' '\x0000') +-- ARMENIAN SMALL LIGATURE ECH YIWN +upperMapping '\x0587' s = Yield '\x0535' (CC s '\x0552' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN NOW +upperMapping '\xfb13' s = Yield '\x0544' (CC s '\x0546' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN ECH +upperMapping '\xfb14' s = Yield '\x0544' (CC s '\x0535' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN INI +upperMapping '\xfb15' s = Yield '\x0544' (CC s '\x053b' '\x0000') +-- ARMENIAN SMALL LIGATURE VEW NOW +upperMapping '\xfb16' s = Yield '\x054e' (CC s '\x0546' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN XEH +upperMapping '\xfb17' s = Yield '\x0544' (CC s '\x053d' '\x0000') +-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +upperMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +upperMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +upperMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301') +-- LATIN SMALL LETTER J WITH CARON +upperMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000') +-- LATIN SMALL LETTER H WITH LINE BELOW +upperMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000') +-- LATIN SMALL LETTER T WITH DIAERESIS +upperMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000') +-- LATIN SMALL LETTER W WITH RING ABOVE +upperMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER Y WITH RING ABOVE +upperMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER A WITH RIGHT HALF RING +upperMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI +upperMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA +upperMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA +upperMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI +upperMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI +upperMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI +upperMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA +upperMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA +upperMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER IOTA WITH PERISPOMENI +upperMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI +upperMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA +upperMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA +upperMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER RHO WITH PSILI +upperMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI +upperMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI +upperMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI +upperMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI +upperMapping '\x1f80' s = Yield '\x1f08' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI +upperMapping '\x1f81' s = Yield '\x1f09' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1f82' s = Yield '\x1f0a' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1f83' s = Yield '\x1f0b' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1f84' s = Yield '\x1f0c' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1f85' s = Yield '\x1f0d' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1f86' s = Yield '\x1f0e' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1f87' s = Yield '\x1f0f' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI +upperMapping '\x1f88' s = Yield '\x1f08' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI +upperMapping '\x1f89' s = Yield '\x1f09' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1f8a' s = Yield '\x1f0a' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1f8b' s = Yield '\x1f0b' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1f8c' s = Yield '\x1f0c' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1f8d' s = Yield '\x1f0d' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1f8e' s = Yield '\x1f0e' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1f8f' s = Yield '\x1f0f' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI +upperMapping '\x1f90' s = Yield '\x1f28' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI +upperMapping '\x1f91' s = Yield '\x1f29' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1f92' s = Yield '\x1f2a' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1f93' s = Yield '\x1f2b' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1f94' s = Yield '\x1f2c' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1f95' s = Yield '\x1f2d' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1f96' s = Yield '\x1f2e' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1f97' s = Yield '\x1f2f' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI +upperMapping '\x1f98' s = Yield '\x1f28' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI +upperMapping '\x1f99' s = Yield '\x1f29' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1f9a' s = Yield '\x1f2a' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1f9b' s = Yield '\x1f2b' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1f9c' s = Yield '\x1f2c' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1f9d' s = Yield '\x1f2d' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1f9e' s = Yield '\x1f2e' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1f9f' s = Yield '\x1f2f' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI +upperMapping '\x1fa0' s = Yield '\x1f68' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI +upperMapping '\x1fa1' s = Yield '\x1f69' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1fa2' s = Yield '\x1f6a' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1fa3' s = Yield '\x1f6b' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1fa4' s = Yield '\x1f6c' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1fa5' s = Yield '\x1f6d' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1fa6' s = Yield '\x1f6e' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1fa7' s = Yield '\x1f6f' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI +upperMapping '\x1fa8' s = Yield '\x1f68' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI +upperMapping '\x1fa9' s = Yield '\x1f69' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1faa' s = Yield '\x1f6a' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1fab' s = Yield '\x1f6b' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1fac' s = Yield '\x1f6c' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1fad' s = Yield '\x1f6d' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1fae' s = Yield '\x1f6e' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1faf' s = Yield '\x1f6f' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI +upperMapping '\x1fb3' s = Yield '\x0391' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI +upperMapping '\x1fbc' s = Yield '\x0391' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI +upperMapping '\x1fc3' s = Yield '\x0397' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI +upperMapping '\x1fcc' s = Yield '\x0397' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI +upperMapping '\x1ff3' s = Yield '\x03a9' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI +upperMapping '\x1ffc' s = Yield '\x03a9' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI +upperMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI +upperMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI +upperMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI +upperMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI +upperMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI +upperMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0399') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0399') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0399') +upperMapping c s = Yield (toUpper c) (CC s '\0' '\0') +lowerMapping :: forall s. Char -> s -> Step (CC s) Char +{-# INLINE lowerMapping #-} +-- LATIN CAPITAL LETTER I WITH DOT ABOVE +lowerMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000') +lowerMapping c s = Yield (toLower c) (CC s '\0' '\0') +titleMapping :: forall s. Char -> s -> Step (CC s) Char +{-# INLINE titleMapping #-} +-- LATIN SMALL LETTER SHARP S +titleMapping '\x00df' s = Yield '\x0053' (CC s '\x0073' '\x0000') +-- LATIN SMALL LIGATURE FF +titleMapping '\xfb00' s = Yield '\x0046' (CC s '\x0066' '\x0000') +-- LATIN SMALL LIGATURE FI +titleMapping '\xfb01' s = Yield '\x0046' (CC s '\x0069' '\x0000') +-- LATIN SMALL LIGATURE FL +titleMapping '\xfb02' s = Yield '\x0046' (CC s '\x006c' '\x0000') +-- LATIN SMALL LIGATURE FFI +titleMapping '\xfb03' s = Yield '\x0046' (CC s '\x0066' '\x0069') +-- LATIN SMALL LIGATURE FFL +titleMapping '\xfb04' s = Yield '\x0046' (CC s '\x0066' '\x006c') +-- LATIN SMALL LIGATURE LONG S T +titleMapping '\xfb05' s = Yield '\x0053' (CC s '\x0074' '\x0000') +-- LATIN SMALL LIGATURE ST +titleMapping '\xfb06' s = Yield '\x0053' (CC s '\x0074' '\x0000') +-- ARMENIAN SMALL LIGATURE ECH YIWN +titleMapping '\x0587' s = Yield '\x0535' (CC s '\x0582' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN NOW +titleMapping '\xfb13' s = Yield '\x0544' (CC s '\x0576' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN ECH +titleMapping '\xfb14' s = Yield '\x0544' (CC s '\x0565' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN INI +titleMapping '\xfb15' s = Yield '\x0544' (CC s '\x056b' '\x0000') +-- ARMENIAN SMALL LIGATURE VEW NOW +titleMapping '\xfb16' s = Yield '\x054e' (CC s '\x0576' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN XEH +titleMapping '\xfb17' s = Yield '\x0544' (CC s '\x056d' '\x0000') +-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +titleMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +titleMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +titleMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301') +-- LATIN SMALL LETTER J WITH CARON +titleMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000') +-- LATIN SMALL LETTER H WITH LINE BELOW +titleMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000') +-- LATIN SMALL LETTER T WITH DIAERESIS +titleMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000') +-- LATIN SMALL LETTER W WITH RING ABOVE +titleMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER Y WITH RING ABOVE +titleMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER A WITH RIGHT HALF RING +titleMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI +titleMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA +titleMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA +titleMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI +titleMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI +titleMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI +titleMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA +titleMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA +titleMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER IOTA WITH PERISPOMENI +titleMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI +titleMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA +titleMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA +titleMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER RHO WITH PSILI +titleMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI +titleMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI +titleMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI +titleMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI +titleMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI +titleMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI +titleMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI +titleMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI +titleMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI +titleMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0345') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0345') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0345') +titleMapping c s = Yield (toTitle c) (CC s '\0' '\0') +foldMapping :: forall s. Char -> s -> Step (CC s) Char +{-# INLINE foldMapping #-} +-- MICRO SIGN +foldMapping '\x00b5' s = Yield '\x03bc' (CC s '\x0000' '\x0000') +-- LATIN SMALL LETTER SHARP S +foldMapping '\x00df' s = Yield '\x0073' (CC s '\x0073' '\x0000') +-- LATIN CAPITAL LETTER I WITH DOT ABOVE +foldMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000') +-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +foldMapping '\x0149' s = Yield '\x02bc' (CC s '\x006e' '\x0000') +-- LATIN SMALL LETTER LONG S +foldMapping '\x017f' s = Yield '\x0073' (CC s '\x0000' '\x0000') +-- LATIN SMALL LETTER J WITH CARON +foldMapping '\x01f0' s = Yield '\x006a' (CC s '\x030c' '\x0000') +-- COMBINING GREEK YPOGEGRAMMENI +foldMapping '\x0345' s = Yield '\x03b9' (CC s '\x0000' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +foldMapping '\x0390' s = Yield '\x03b9' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +foldMapping '\x03b0' s = Yield '\x03c5' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER FINAL SIGMA +foldMapping '\x03c2' s = Yield '\x03c3' (CC s '\x0000' '\x0000') +-- GREEK BETA SYMBOL +foldMapping '\x03d0' s = Yield '\x03b2' (CC s '\x0000' '\x0000') +-- GREEK THETA SYMBOL +foldMapping '\x03d1' s = Yield '\x03b8' (CC s '\x0000' '\x0000') +-- GREEK PHI SYMBOL +foldMapping '\x03d5' s = Yield '\x03c6' (CC s '\x0000' '\x0000') +-- GREEK PI SYMBOL +foldMapping '\x03d6' s = Yield '\x03c0' (CC s '\x0000' '\x0000') +-- GREEK KAPPA SYMBOL +foldMapping '\x03f0' s = Yield '\x03ba' (CC s '\x0000' '\x0000') +-- GREEK RHO SYMBOL +foldMapping '\x03f1' s = Yield '\x03c1' (CC s '\x0000' '\x0000') +-- GREEK LUNATE EPSILON SYMBOL +foldMapping '\x03f5' s = Yield '\x03b5' (CC s '\x0000' '\x0000') +-- ARMENIAN SMALL LIGATURE ECH YIWN +foldMapping '\x0587' s = Yield '\x0565' (CC s '\x0582' '\x0000') +-- GEORGIAN CAPITAL LETTER YN +foldMapping '\x10c7' s = Yield '\x2d27' (CC s '\x0000' '\x0000') +-- GEORGIAN CAPITAL LETTER AEN +foldMapping '\x10cd' s = Yield '\x2d2d' (CC s '\x0000' '\x0000') +-- LATIN SMALL LETTER H WITH LINE BELOW +foldMapping '\x1e96' s = Yield '\x0068' (CC s '\x0331' '\x0000') +-- LATIN SMALL LETTER T WITH DIAERESIS +foldMapping '\x1e97' s = Yield '\x0074' (CC s '\x0308' '\x0000') +-- LATIN SMALL LETTER W WITH RING ABOVE +foldMapping '\x1e98' s = Yield '\x0077' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER Y WITH RING ABOVE +foldMapping '\x1e99' s = Yield '\x0079' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER A WITH RIGHT HALF RING +foldMapping '\x1e9a' s = Yield '\x0061' (CC s '\x02be' '\x0000') +-- LATIN SMALL LETTER LONG S WITH DOT ABOVE +foldMapping '\x1e9b' s = Yield '\x1e61' (CC s '\x0000' '\x0000') +-- LATIN CAPITAL LETTER SHARP S +foldMapping '\x1e9e' s = Yield '\x0073' (CC s '\x0073' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI +foldMapping '\x1f50' s = Yield '\x03c5' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA +foldMapping '\x1f52' s = Yield '\x03c5' (CC s '\x0313' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA +foldMapping '\x1f54' s = Yield '\x03c5' (CC s '\x0313' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI +foldMapping '\x1f56' s = Yield '\x03c5' (CC s '\x0313' '\x0342') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI +foldMapping '\x1f80' s = Yield '\x1f00' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI +foldMapping '\x1f81' s = Yield '\x1f01' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1f82' s = Yield '\x1f02' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1f83' s = Yield '\x1f03' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1f84' s = Yield '\x1f04' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1f85' s = Yield '\x1f05' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1f86' s = Yield '\x1f06' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1f87' s = Yield '\x1f07' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI +foldMapping '\x1f88' s = Yield '\x1f00' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI +foldMapping '\x1f89' s = Yield '\x1f01' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1f8a' s = Yield '\x1f02' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1f8b' s = Yield '\x1f03' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1f8c' s = Yield '\x1f04' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1f8d' s = Yield '\x1f05' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1f8e' s = Yield '\x1f06' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1f8f' s = Yield '\x1f07' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI +foldMapping '\x1f90' s = Yield '\x1f20' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI +foldMapping '\x1f91' s = Yield '\x1f21' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1f92' s = Yield '\x1f22' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1f93' s = Yield '\x1f23' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1f94' s = Yield '\x1f24' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1f95' s = Yield '\x1f25' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1f96' s = Yield '\x1f26' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1f97' s = Yield '\x1f27' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI +foldMapping '\x1f98' s = Yield '\x1f20' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI +foldMapping '\x1f99' s = Yield '\x1f21' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1f9a' s = Yield '\x1f22' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1f9b' s = Yield '\x1f23' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1f9c' s = Yield '\x1f24' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1f9d' s = Yield '\x1f25' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1f9e' s = Yield '\x1f26' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1f9f' s = Yield '\x1f27' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI +foldMapping '\x1fa0' s = Yield '\x1f60' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI +foldMapping '\x1fa1' s = Yield '\x1f61' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1fa2' s = Yield '\x1f62' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1fa3' s = Yield '\x1f63' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1fa4' s = Yield '\x1f64' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1fa5' s = Yield '\x1f65' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1fa6' s = Yield '\x1f66' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1fa7' s = Yield '\x1f67' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI +foldMapping '\x1fa8' s = Yield '\x1f60' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI +foldMapping '\x1fa9' s = Yield '\x1f61' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1faa' s = Yield '\x1f62' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1fab' s = Yield '\x1f63' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1fac' s = Yield '\x1f64' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1fad' s = Yield '\x1f65' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1fae' s = Yield '\x1f66' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1faf' s = Yield '\x1f67' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI +foldMapping '\x1fb2' s = Yield '\x1f70' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI +foldMapping '\x1fb3' s = Yield '\x03b1' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI +foldMapping '\x1fb4' s = Yield '\x03ac' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI +foldMapping '\x1fb6' s = Yield '\x03b1' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1fb7' s = Yield '\x03b1' (CC s '\x0342' '\x03b9') +-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI +foldMapping '\x1fbc' s = Yield '\x03b1' (CC s '\x03b9' '\x0000') +-- GREEK PROSGEGRAMMENI +foldMapping '\x1fbe' s = Yield '\x03b9' (CC s '\x0000' '\x0000') +-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI +foldMapping '\x1fc2' s = Yield '\x1f74' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI +foldMapping '\x1fc3' s = Yield '\x03b7' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI +foldMapping '\x1fc4' s = Yield '\x03ae' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI +foldMapping '\x1fc6' s = Yield '\x03b7' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1fc7' s = Yield '\x03b7' (CC s '\x0342' '\x03b9') +-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI +foldMapping '\x1fcc' s = Yield '\x03b7' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA +foldMapping '\x1fd2' s = Yield '\x03b9' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA +foldMapping '\x1fd3' s = Yield '\x03b9' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER IOTA WITH PERISPOMENI +foldMapping '\x1fd6' s = Yield '\x03b9' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI +foldMapping '\x1fd7' s = Yield '\x03b9' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA +foldMapping '\x1fe2' s = Yield '\x03c5' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA +foldMapping '\x1fe3' s = Yield '\x03c5' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER RHO WITH PSILI +foldMapping '\x1fe4' s = Yield '\x03c1' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI +foldMapping '\x1fe6' s = Yield '\x03c5' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI +foldMapping '\x1fe7' s = Yield '\x03c5' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI +foldMapping '\x1ff2' s = Yield '\x1f7c' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI +foldMapping '\x1ff3' s = Yield '\x03c9' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI +foldMapping '\x1ff4' s = Yield '\x03ce' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI +foldMapping '\x1ff6' s = Yield '\x03c9' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1ff7' s = Yield '\x03c9' (CC s '\x0342' '\x03b9') +-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI +foldMapping '\x1ffc' s = Yield '\x03c9' (CC s '\x03b9' '\x0000') +-- COPTIC CAPITAL LETTER BOHAIRIC KHEI +foldMapping '\x2cf2' s = Yield '\x2cf3' (CC s '\x0000' '\x0000') +-- LATIN CAPITAL LETTER C WITH BAR +foldMapping '\xa792' s = Yield '\xa793' (CC s '\x0000' '\x0000') +-- LATIN CAPITAL LETTER H WITH HOOK +foldMapping '\xa7aa' s = Yield '\x0266' (CC s '\x0000' '\x0000') +-- LATIN SMALL LIGATURE FF +foldMapping '\xfb00' s = Yield '\x0066' (CC s '\x0066' '\x0000') +-- LATIN SMALL LIGATURE FI +foldMapping '\xfb01' s = Yield '\x0066' (CC s '\x0069' '\x0000') +-- LATIN SMALL LIGATURE FL +foldMapping '\xfb02' s = Yield '\x0066' (CC s '\x006c' '\x0000') +-- LATIN SMALL LIGATURE FFI +foldMapping '\xfb03' s = Yield '\x0066' (CC s '\x0066' '\x0069') +-- LATIN SMALL LIGATURE FFL +foldMapping '\xfb04' s = Yield '\x0066' (CC s '\x0066' '\x006c') +-- LATIN SMALL LIGATURE LONG S T +foldMapping '\xfb05' s = Yield '\x0073' (CC s '\x0074' '\x0000') +-- LATIN SMALL LIGATURE ST +foldMapping '\xfb06' s = Yield '\x0073' (CC s '\x0074' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN NOW +foldMapping '\xfb13' s = Yield '\x0574' (CC s '\x0576' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN ECH +foldMapping '\xfb14' s = Yield '\x0574' (CC s '\x0565' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN INI +foldMapping '\xfb15' s = Yield '\x0574' (CC s '\x056b' '\x0000') +-- ARMENIAN SMALL LIGATURE VEW NOW +foldMapping '\xfb16' s = Yield '\x057e' (CC s '\x0576' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN XEH +foldMapping '\xfb17' s = Yield '\x0574' (CC s '\x056d' '\x0000') +foldMapping c s = Yield (toLower c) (CC s '\0' '\0') diff --git a/Data/Text/Internal/Fusion/Common.hs b/Data/Text/Internal/Fusion/Common.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Fusion/Common.hs @@ -0,0 +1,950 @@ +{-# LANGUAGE BangPatterns, MagicHash, Rank2Types #-} +-- | +-- Module : Data.Text.Internal.Fusion.Common +-- Copyright : (c) Bryan O'Sullivan 2009, 2012 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Common stream fusion functionality for text. + +module Data.Text.Internal.Fusion.Common + ( + -- * Creation and elimination + singleton + , streamList + , unstreamList + , streamCString# + + -- * Basic interface + , cons + , snoc + , append + , head + , uncons + , last + , tail + , init + , null + , lengthI + , compareLengthI + , isSingleton + + -- * Transformations + , map + , intercalate + , intersperse + + -- ** Case conversion + -- $case + , toCaseFold + , toLower + , toTitle + , toUpper + + -- ** Justification + , justifyLeftI + + -- * Folds + , foldl + , foldl' + , foldl1 + , foldl1' + , foldr + , foldr1 + + -- ** Special folds + , concat + , concatMap + , any + , all + , maximum + , minimum + + -- * Construction + -- ** Scans + , scanl + + -- ** Accumulating maps + -- , mapAccumL + + -- ** Generation and unfolding + , replicateCharI + , replicateI + , unfoldr + , unfoldrNI + + -- * Substrings + -- ** Breaking strings + , take + , drop + , takeWhile + , dropWhile + + -- * Predicates + , isPrefixOf + + -- * Searching + , elem + , filter + + -- * Indexing + , findBy + , indexI + , findIndexI + , countCharI + + -- * Zipping and unzipping + , zipWith + ) where + +import Prelude (Bool(..), Char, Eq(..), Int, Integral, Maybe(..), + Ord(..), Ordering(..), String, (.), ($), (+), (-), (*), (++), + (&&), fromIntegral, not, otherwise) +import qualified Data.List as L +import qualified Prelude as P +import Data.Bits (shiftL) +import Data.Char (isLetter) +import Data.Int (Int64) +import Data.Text.Internal.Fusion.Types +import Data.Text.Internal.Fusion.CaseMapping (foldMapping, lowerMapping, titleMapping, + upperMapping) +import Data.Text.Internal.Fusion.Size +import GHC.Prim (Addr#, chr#, indexCharOffAddr#, ord#) +import GHC.Types (Char(..), Int(..)) + +singleton :: Char -> Stream Char +singleton c = Stream next False 1 + where next False = Yield c True + next True = Done +{-# INLINE singleton #-} + +streamList :: [a] -> Stream a +{-# INLINE [0] streamList #-} +streamList s = Stream next s unknownSize + where next [] = Done + next (x:xs) = Yield x xs + +unstreamList :: Stream a -> [a] +unstreamList (Stream next s0 _len) = unfold s0 + where unfold !s = case next s of + Done -> [] + Skip s' -> unfold s' + Yield x s' -> x : unfold s' +{-# INLINE [0] unstreamList #-} + +{-# RULES "STREAM streamList/unstreamList fusion" forall s. streamList (unstreamList s) = s #-} + +-- | Stream the UTF-8-like packed encoding used by GHC to represent +-- constant strings in generated code. +-- +-- This encoding uses the byte sequence "\xc0\x80" to represent NUL, +-- and the string is NUL-terminated. +streamCString# :: Addr# -> Stream Char +streamCString# addr = Stream step 0 unknownSize + where + step !i + | b == 0 = Done + | b <= 0x7f = Yield (C# b#) (i+1) + | b <= 0xdf = let !c = chr $ ((b-0xc0) `shiftL` 6) + next 1 + in Yield c (i+2) + | b <= 0xef = let !c = chr $ ((b-0xe0) `shiftL` 12) + + (next 1 `shiftL` 6) + + next 2 + in Yield c (i+3) + | otherwise = let !c = chr $ ((b-0xf0) `shiftL` 18) + + (next 1 `shiftL` 12) + + (next 2 `shiftL` 6) + + next 3 + in Yield c (i+4) + where b = I# (ord# b#) + next n = I# (ord# (at# (i+n))) - 0x80 + !b# = at# i + at# (I# i#) = indexCharOffAddr# addr i# + chr (I# i#) = C# (chr# i#) +{-# INLINE [0] streamCString# #-} + +-- ---------------------------------------------------------------------------- +-- * Basic stream functions + +data C s = C0 !s + | C1 !s + +-- | /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 (C1 s0) (len+1) + where + next (C1 s) = Yield w (C0 s) + next (C0 s) = case next0 s of + Done -> Done + Skip s' -> Skip (C0 s') + Yield x s' -> Yield x (C0 s') +{-# INLINE [0] cons #-} + +-- | /O(n)/ Adds a character to the end of a stream. +snoc :: Stream Char -> Char -> Stream Char +snoc (Stream next0 xs0 len) w = Stream next (J xs0) (len+1) + where + next (J xs) = case next0 xs of + Done -> Yield w N + Skip xs' -> Skip (J xs') + Yield x xs' -> Yield x (J xs') + next N = Done +{-# INLINE [0] snoc #-} + +data E l r = L !l + | R !r + +-- | /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 (L s01) (len1 + len2) + where + next (L s1) = case next0 s1 of + Done -> Skip (R s02) + Skip s1' -> Skip (L s1') + Yield x s1' -> Yield x (L s1') + next (R s2) = case next1 s2 of + Done -> Done + Skip s2' -> Skip (R s2') + Yield x s2' -> Yield x (R 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 -> head_empty +{-# INLINE [0] head #-} + +head_empty :: a +head_empty = streamError "head" "Empty stream" +{-# NOINLINE head_empty #-} + +-- | /O(1)/ Returns the first character and remainder of a 'Stream +-- Char', or 'Nothing' if empty. Subject to array fusion. +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 (C0 s0) (len-1) + where + next (C0 s) = case next0 s of + Done -> emptyError "tail" + Skip s' -> Skip (C0 s') + Yield _ s' -> Skip (C1 s') + next (C1 s) = case next0 s of + Done -> Done + Skip s' -> Skip (C1 s') + Yield x s' -> Yield x (C1 s') +{-# INLINE [0] tail #-} + +data Init s = Init0 !s + | Init1 {-# UNPACK #-} !Char !s + +-- | /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 (Init0 s0) (len-1) + where + next (Init0 s) = case next0 s of + Done -> emptyError "init" + Skip s' -> Skip (Init0 s') + Yield x s' -> Skip (Init1 x s') + next (Init1 x s) = case next0 s of + Done -> Done + Skip s' -> Skip (Init1 x s') + Yield x' s' -> Yield x (Init1 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 string. +lengthI :: Integral a => Stream Char -> a +lengthI (Stream next s0 _len) = loop_length 0 s0 + where + loop_length !z s = case next s of + Done -> z + Skip s' -> loop_length z s' + Yield _ s' -> loop_length (z + 1) s' +{-# INLINE[0] lengthI #-} + +-- | /O(n)/ Compares the count of characters in a string to a number. +-- Subject to fusion. +-- +-- This function gives the same answer as comparing against the result +-- of 'lengthI', but can short circuit if the count of characters is +-- greater than the number, and hence be more efficient. +compareLengthI :: Integral a => Stream Char -> a -> Ordering +compareLengthI (Stream next s0 len) n = + case exactly len of + Nothing -> loop_cmp 0 s0 + Just i -> compare (fromIntegral i) n + where + loop_cmp !z s = case next s of + Done -> compare z n + Skip s' -> loop_cmp z s' + Yield _ s' | z > n -> GT + | otherwise -> loop_cmp (z + 1) s' +{-# INLINE[0] compareLengthI #-} + +-- | /O(n)/ Indicate whether a string contains exactly one element. +isSingleton :: Stream Char -> Bool +isSingleton (Stream next s0 _len) = loop 0 s0 + where + loop !z s = case next s of + Done -> z == (1::Int) + Skip s' -> loop z s' + Yield _ s' + | z >= 1 -> False + | otherwise -> loop (z+1) s' +{-# INLINE[0] isSingleton #-} + +-- ---------------------------------------------------------------------------- +-- * 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 + 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 + #-} + +data I s = I1 !s + | I2 !s {-# UNPACK #-} !Char + | I3 !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 (I1 s0) len + where + next (I1 s) = case next0 s of + Done -> Done + Skip s' -> Skip (I1 s') + Yield x s' -> Skip (I2 s' x) + next (I2 s x) = Yield x (I3 s) + next (I3 s) = case next0 s of + Done -> Done + Skip s' -> Skip (I3 s') + Yield x s' -> Yield c (I2 s' x) +{-# INLINE [0] intersperse #-} + +-- ---------------------------------------------------------------------------- +-- ** Case conversions (folds) + +-- $case +-- +-- With Unicode text, it is incorrect to use combinators like @map +-- toUpper@ to case convert each character of a string individually. +-- Instead, use the whole-string case conversion functions from this +-- module. For correctness in different writing systems, these +-- functions may map one input character to two or three output +-- characters. + +caseConvert :: (forall s. Char -> s -> Step (CC s) Char) + -> Stream Char -> Stream Char +caseConvert remap (Stream next0 s0 len) = Stream next (CC s0 '\0' '\0') len + where + next (CC s '\0' _) = + case next0 s of + Done -> Done + Skip s' -> Skip (CC s' '\0' '\0') + Yield c s' -> remap c s' + next (CC s a b) = Yield a (CC s b '\0') + +-- | /O(n)/ Convert a string to folded case. This function is mainly +-- useful for performing caseless (or case insensitive) string +-- comparisons. +-- +-- A string @x@ is a caseless match for a string @y@ if and only if: +-- +-- @toCaseFold x == toCaseFold y@ +-- +-- The result string may be longer than the input string, and may +-- differ from applying 'toLower' to the input string. For instance, +-- the Armenian small ligature men now (U+FB13) is case folded to the +-- bigram men now (U+0574 U+0576), while the micro sign (U+00B5) is +-- case folded to the Greek small letter letter mu (U+03BC) instead of +-- itself. +toCaseFold :: Stream Char -> Stream Char +toCaseFold = caseConvert foldMapping +{-# INLINE [0] toCaseFold #-} + +-- | /O(n)/ Convert a string to upper case, using simple case +-- conversion. The result string may be longer than the input string. +-- For instance, the German eszett (U+00DF) maps to the two-letter +-- sequence SS. +toUpper :: Stream Char -> Stream Char +toUpper = caseConvert upperMapping +{-# INLINE [0] toUpper #-} + +-- | /O(n)/ Convert a string to lower case, using simple case +-- conversion. The result string may be longer than the input string. +-- For instance, the Latin capital letter I with dot above (U+0130) +-- maps to the sequence Latin small letter i (U+0069) followed by +-- combining dot above (U+0307). +toLower :: Stream Char -> Stream Char +toLower = caseConvert lowerMapping +{-# INLINE [0] toLower #-} + +-- | /O(n)/ Convert a string to title case, using simple case +-- conversion. +-- +-- The first letter of the input is converted to title case, as is +-- every subsequent letter that immediately follows a non-letter. +-- Every letter that immediately follows another letter is converted +-- to lower case. +-- +-- The result string may be longer than the input string. For example, +-- the Latin small ligature fl (U+FB02) is converted to the +-- sequence Latin capital letter F (U+0046) followed by Latin small +-- letter l (U+006C). +-- +-- /Note/: this function does not take language or culture specific +-- rules into account. For instance, in English, different style +-- guides disagree on whether the book name \"The Hill of the Red +-- Fox\" is correctly title cased—but this function will +-- capitalize /every/ word. +toTitle :: Stream Char -> Stream Char +toTitle (Stream next0 s0 len) = Stream next (CC (False :*: s0) '\0' '\0') len + where + next (CC (letter :*: s) '\0' _) = + case next0 s of + Done -> Done + Skip s' -> Skip (CC (letter :*: s') '\0' '\0') + Yield c s' + | letter' -> if letter + then lowerMapping c (letter' :*: s') + else titleMapping c (letter' :*: s') + | otherwise -> Yield c (CC (letter' :*: s') '\0' '\0') + where letter' = isLetter c + next (CC s a b) = Yield a (CC s b '\0') +{-# INLINE [0] toTitle #-} + +justifyLeftI :: Integral a => a -> Char -> Stream Char -> Stream Char +justifyLeftI k c (Stream next0 s0 len) = + Stream next (s0 :*: S1 :*: 0) (larger (fromIntegral k) len) + where + next (s :*: S1 :*: n) = + case next0 s of + Done -> next (s :*: S2 :*: n) + Skip s' -> Skip (s' :*: S1 :*: n) + Yield x s' -> Yield x (s' :*: S1 :*: n+1) + next (s :*: S2 :*: n) + | n < k = Yield c (s :*: S2 :*: n+1) + | otherwise = Done + {-# INLINE next #-} +{-# INLINE [0] justifyLeftI #-} + +-- ---------------------------------------------------------------------------- +-- * Reducing Streams (folds) + +-- | foldl, applied to a binary operator, a starting value (typically the +-- left-identity of the operator), and a Stream, reduces the Stream using the +-- binary operator, from left to right. +foldl :: (b -> Char -> b) -> b -> Stream Char -> b +foldl f z0 (Stream next s0 _len) = loop_foldl z0 s0 + where + loop_foldl z !s = case next s of + Done -> z + Skip s' -> loop_foldl z s' + Yield x s' -> loop_foldl (f z x) s' +{-# INLINE [0] foldl #-} + +-- | A strict version of foldl. +foldl' :: (b -> Char -> b) -> b -> Stream Char -> b +foldl' f z0 (Stream next s0 _len) = loop_foldl' z0 s0 + where + loop_foldl' !z !s = case next s of + Done -> z + Skip s' -> loop_foldl' z s' + Yield x s' -> loop_foldl' (f z x) s' +{-# INLINE [0] foldl' #-} + +-- | foldl1 is a variant of foldl that has no starting value argument, +-- and thus must be applied to non-empty Streams. +foldl1 :: (Char -> Char -> Char) -> Stream Char -> Char +foldl1 f (Stream next s0 _len) = loop0_foldl1 s0 + where + loop0_foldl1 !s = case next s of + Skip s' -> loop0_foldl1 s' + Yield x s' -> loop_foldl1 x s' + Done -> emptyError "foldl1" + loop_foldl1 z !s = case next s of + Done -> z + Skip s' -> loop_foldl1 z s' + Yield x s' -> loop_foldl1 (f z x) s' +{-# INLINE [0] foldl1 #-} + +-- | A strict version of foldl1. +foldl1' :: (Char -> Char -> Char) -> Stream Char -> Char +foldl1' f (Stream next s0 _len) = loop0_foldl1' s0 + where + loop0_foldl1' !s = case next s of + Skip s' -> loop0_foldl1' s' + Yield x s' -> loop_foldl1' x s' + Done -> emptyError "foldl1" + loop_foldl1' !z !s = case next s of + Done -> z + Skip s' -> loop_foldl1' z s' + Yield x s' -> loop_foldl1' (f z x) s' +{-# INLINE [0] foldl1' #-} + +-- | 'foldr', applied to a binary operator, a starting value (typically the +-- right-identity of the operator), and a stream, reduces the stream using the +-- binary operator, from right to left. +foldr :: (Char -> b -> b) -> b -> Stream Char -> b +foldr f z (Stream next s0 _len) = loop_foldr s0 + where + loop_foldr !s = case next s of + Done -> z + Skip s' -> loop_foldr s' + Yield x s' -> f x (loop_foldr s') +{-# INLINE [0] foldr #-} + +-- | foldr1 is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty streams. +-- Subject to array fusion. +foldr1 :: (Char -> Char -> Char) -> Stream Char -> Char +foldr1 f (Stream next s0 _len) = loop0_foldr1 s0 + where + loop0_foldr1 !s = case next s of + Done -> emptyError "foldr1" + Skip s' -> loop0_foldr1 s' + Yield x s' -> loop_foldr1 x s' + + loop_foldr1 x !s = case next s of + Done -> x + Skip s' -> loop_foldr1 x s' + Yield x' s' -> f x (loop_foldr1 x' s') +{-# INLINE [0] foldr1 #-} + +intercalate :: Stream Char -> [Stream Char] -> Stream Char +intercalate s = concat . (L.intersperse s) +{-# INLINE [0] intercalate #-} + +-- ---------------------------------------------------------------------------- +-- ** Special folds + +-- | /O(n)/ Concatenate a list of streams. Subject to array fusion. +concat :: [Stream Char] -> Stream Char +concat = L.foldr append empty +{-# INLINE [0] 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 +{-# INLINE [0] concatMap #-} + +-- | /O(n)/ any @p @xs determines if any character in the stream +-- @xs@ satisifes the predicate @p@. +any :: (Char -> Bool) -> Stream Char -> Bool +any p (Stream next0 s0 _len) = loop_any s0 + where + loop_any !s = case next0 s of + Done -> False + Skip s' -> loop_any s' + Yield x s' | p x -> True + | otherwise -> loop_any s' +{-# INLINE [0] any #-} + +-- | /O(n)/ all @p @xs determines if all characters in the 'Text' +-- @xs@ satisify the predicate @p@. +all :: (Char -> Bool) -> Stream Char -> Bool +all p (Stream next0 s0 _len) = loop_all s0 + where + loop_all !s = case next0 s of + Done -> True + Skip s' -> loop_all s' + Yield x s' | p x -> loop_all s' + | otherwise -> False +{-# INLINE [0] all #-} + +-- | /O(n)/ maximum returns the maximum value from a stream, which must be +-- non-empty. +maximum :: Stream Char -> Char +maximum (Stream next0 s0 _len) = loop0_maximum s0 + where + loop0_maximum !s = case next0 s of + Done -> emptyError "maximum" + Skip s' -> loop0_maximum s' + Yield x s' -> loop_maximum x s' + loop_maximum !z !s = case next0 s of + Done -> z + Skip s' -> loop_maximum z s' + Yield x s' + | x > z -> loop_maximum x s' + | otherwise -> loop_maximum z s' +{-# INLINE [0] maximum #-} + +-- | /O(n)/ minimum returns the minimum value from a 'Text', which must be +-- non-empty. +minimum :: Stream Char -> Char +minimum (Stream next0 s0 _len) = loop0_minimum s0 + where + loop0_minimum !s = case next0 s of + Done -> emptyError "minimum" + Skip s' -> loop0_minimum s' + Yield x s' -> loop_minimum x s' + loop_minimum !z !s = case next0 s of + Done -> z + Skip s' -> loop_minimum z s' + Yield x s' + | x < z -> loop_minimum x s' + | otherwise -> loop_minimum z s' +{-# INLINE [0] minimum #-} + +-- ----------------------------------------------------------------------------- +-- * Building streams + +scanl :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char +scanl f z0 (Stream next0 s0 len) = Stream next (S1 :*: z0 :*: s0) (len+1) -- HINT maybe too low + where + {-# INLINE next #-} + next (S1 :*: z :*: s) = Yield z (S2 :*: z :*: s) + next (S2 :*: z :*: s) = case next0 s of + Yield x s' -> let !x' = f z x + in Yield x' (S2 :*: x' :*: s') + Skip s' -> Skip (S2 :*: z :*: s') + Done -> Done +{-# INLINE [0] scanl #-} + +-- ----------------------------------------------------------------------------- +-- ** Accumulating maps + +{- +-- | /O(n)/ Like a combination of 'map' and 'foldl'. Applies a +-- function to each element of a stream, passing an accumulating +-- parameter from left to right, and returns a final stream. +-- +-- /Note/: Unlike the version over lists, this function does not +-- return a final value for the accumulator, because the nature of +-- streams precludes it. +mapAccumL :: (a -> b -> (a,b)) -> a -> Stream b -> Stream b +mapAccumL f z0 (Stream next0 s0 len) = Stream next (s0 :*: z0) len -- HINT depends on f + where + {-# INLINE next #-} + next (s :*: z) = case next0 s of + Yield x s' -> let (z',y) = f z x + in Yield y (s' :*: z') + Skip s' -> Skip (s' :*: z) + Done -> Done +{-# INLINE [0] mapAccumL #-} +-} + +-- ----------------------------------------------------------------------------- +-- ** Generating and unfolding streams + +replicateCharI :: Integral a => a -> Char -> Stream Char +replicateCharI n c + | n < 0 = empty + | otherwise = Stream next 0 (fromIntegral n) -- HINT maybe too low + where + next i | i >= n = Done + | otherwise = Yield c (i + 1) +{-# INLINE [0] replicateCharI #-} + +data RI s = RI !s {-# UNPACK #-} !Int64 + +replicateI :: Int64 -> Stream Char -> Stream Char +replicateI n (Stream next0 s0 len) = + Stream next (RI s0 0) (fromIntegral (max 0 n) * len) + where + next (RI s k) + | k >= n = Done + | otherwise = case next0 s of + Done -> Skip (RI s0 (k+1)) + Skip s' -> Skip (RI s' k) + Yield x s' -> Yield x (RI s' k) +{-# INLINE [0] replicateI #-} + +-- | /O(n)/, where @n@ is the length of the result. The unfoldr function +-- is analogous to the List 'unfoldr'. unfoldr builds a stream +-- from a seed value. The function takes the element and returns +-- Nothing if it is done producing the stream or returns Just +-- (a,b), in which case, a is the next Char in the string, and b is +-- the seed value for further production. +unfoldr :: (a -> Maybe (Char,a)) -> a -> Stream Char +unfoldr f s0 = Stream next s0 1 -- HINT maybe too low + where + {-# INLINE next #-} + next !s = case f s of + Nothing -> Done + Just (w, s') -> Yield w s' +{-# INLINE [0] unfoldr #-} + +-- | /O(n)/ Like 'unfoldr', 'unfoldrNI' builds a stream from a seed +-- value. However, the length of the result is limited by the +-- first argument to 'unfoldrNI'. This function is more efficient than +-- 'unfoldr' when the length of the result is known. +unfoldrNI :: Integral a => a -> (b -> Maybe (Char,b)) -> b -> Stream Char +unfoldrNI n f s0 | n < 0 = empty + | otherwise = Stream next (0 :*: s0) (fromIntegral (n*2)) -- HINT maybe too high + where + {-# INLINE next #-} + next (z :*: s) = case f s of + Nothing -> Done + Just (w, s') | z >= n -> Done + | otherwise -> Yield w ((z + 1) :*: s') +{-# INLINE unfoldrNI #-} + +------------------------------------------------------------------------------- +-- * Substreams + +-- | /O(n)/ take n, applied to a stream, returns the prefix of the +-- stream of length @n@, or the stream itself if @n@ is greater than the +-- length of the stream. +take :: Integral a => a -> Stream Char -> Stream Char +take n0 (Stream next0 s0 len) = + Stream next (n0 :*: s0) (smaller len (fromIntegral (max 0 n0))) + 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 after the first @n@ characters, or the empty stream if @n@ +-- is greater than the length of the stream. +drop :: Integral a => a -> Stream Char -> Stream Char +drop n0 (Stream next0 s0 len) = + Stream next (J n0 :*: s0) (len - fromIntegral (max 0 n0)) + where + {-# INLINE next #-} + next (J n :*: s) + | n <= 0 = Skip (N :*: s) + | otherwise = case next0 s of + Done -> Done + Skip s' -> Skip (J n :*: s') + Yield _ s' -> Skip (J (n-1) :*: s') + next (N :*: s) = case next0 s of + Done -> Done + Skip s' -> Skip (N :*: s') + Yield x s' -> Yield x (N :*: s') +{-# INLINE [0] drop #-} + +-- | takeWhile, applied to a predicate @p@ and a stream, returns the +-- longest prefix (possibly empty) of elements that satisfy p. +takeWhile :: (Char -> Bool) -> Stream Char -> Stream Char +takeWhile p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high + where + {-# INLINE next #-} + next !s = case next0 s of + Done -> Done + Skip s' -> Skip s' + Yield x s' | p x -> Yield x s' + | otherwise -> Done +{-# INLINE [0] takeWhile #-} + +-- | dropWhile @p @xs returns the suffix remaining after takeWhile @p @xs. +dropWhile :: (Char -> Bool) -> Stream Char -> Stream Char +dropWhile p (Stream next0 s0 len) = Stream next (S1 :*: s0) len -- HINT maybe too high + where + {-# INLINE next #-} + next (S1 :*: s) = case next0 s of + Done -> Done + Skip s' -> Skip (S1 :*: s') + Yield x s' | p x -> Skip (S1 :*: s') + | otherwise -> Yield x (S2 :*: s') + next (S2 :*: s) = case next0 s of + Done -> Done + Skip s' -> Skip (S2 :*: s') + Yield x s' -> Yield x (S2 :*: s') +{-# INLINE [0] dropWhile #-} + +-- | /O(n)/ The 'isPrefixOf' function takes two 'Stream's and returns +-- 'True' iff the first is a prefix of the second. +isPrefixOf :: (Eq a) => Stream a -> Stream a -> Bool +isPrefixOf (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2) + where + loop Done _ = True + loop _ Done = False + loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2') + loop (Skip s1') x2 = loop (next1 s1') x2 + loop x1 (Skip s2') = loop x1 (next2 s2') + loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 && + loop (next1 s1') (next2 s2') +{-# INLINE [0] isPrefixOf #-} + +-- ---------------------------------------------------------------------------- +-- * 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 'findBy' function takes a predicate and a stream, +-- and returns the first element in matching the predicate, or 'Nothing' +-- if there is no such element. + +findBy :: (Char -> Bool) -> Stream Char -> Maybe Char +findBy 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] findBy #-} + +-- | /O(n)/ Stream index (subscript) operator, starting from 0. +indexI :: Integral a => Stream Char -> a -> Char +indexI (Stream next s0 _len) n0 + | n0 < 0 = streamError "index" "Negative index" + | otherwise = loop_index n0 s0 + where + loop_index !n !s = case next s of + Done -> streamError "index" "Index too large" + Skip s' -> loop_index n s' + Yield x s' | n == 0 -> x + | otherwise -> loop_index (n-1) s' +{-# INLINE [0] indexI #-} + +-- | /O(n)/ 'filter', applied to a predicate and a stream, +-- returns a stream containing those characters that satisfy the +-- predicate. +filter :: (Char -> Bool) -> Stream Char -> Stream Char +filter p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high + where + next !s = case next0 s of + Done -> Done + Skip s' -> Skip s' + Yield x s' | p x -> Yield x s' + | otherwise -> Skip s' +{-# INLINE [0] filter #-} + +{-# RULES + "STREAM filter/filter fusion" forall p q s. + filter p (filter q s) = filter (\x -> q x && p x) s + #-} + +-- | The 'findIndexI' function takes a predicate and a stream and +-- returns the index of the first element in the stream satisfying the +-- predicate. +findIndexI :: Integral a => (Char -> Bool) -> Stream Char -> Maybe a +findIndexI p s = case findIndicesI p s of + (i:_) -> Just i + _ -> Nothing +{-# INLINE [0] findIndexI #-} + +-- | The 'findIndicesI' function takes a predicate and a stream and +-- returns all indices of the elements in the stream satisfying the +-- predicate. +findIndicesI :: Integral a => (Char -> Bool) -> Stream Char -> [a] +findIndicesI p (Stream next s0 _len) = loop_findIndex 0 s0 + where + loop_findIndex !i !s = case next s of + Done -> [] + Skip s' -> loop_findIndex i s' -- hmm. not caught by QC + Yield x s' | p x -> i : loop_findIndex (i+1) s' + | otherwise -> loop_findIndex (i+1) s' +{-# INLINE [0] findIndicesI #-} + +------------------------------------------------------------------------------- +-- * Zipping + +-- | zipWith generalises 'zip' by zipping with the function given as +-- the first argument, instead of a tupling function. +zipWith :: (a -> a -> b) -> Stream a -> Stream a -> Stream b +zipWith f (Stream next0 sa0 len1) (Stream next1 sb0 len2) = + Stream next (sa0 :*: sb0 :*: N) (smaller len1 len2) + where + next (sa :*: sb :*: N) = case next0 sa of + Done -> Done + Skip sa' -> Skip (sa' :*: sb :*: N) + Yield a sa' -> Skip (sa' :*: sb :*: J a) + + next (sa' :*: sb :*: J a) = case next1 sb of + Done -> Done + Skip sb' -> Skip (sa' :*: sb' :*: J a) + Yield b sb' -> Yield (f a b) (sa' :*: sb' :*: N) +{-# INLINE [0] zipWith #-} + +-- | /O(n)/ The 'countCharI' function returns the number of times the +-- query element appears in the given stream. +countCharI :: Integral a => Char -> Stream Char -> a +countCharI 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] countCharI #-} + +streamError :: String -> String -> a +streamError func msg = P.error $ "Data.Text.Internal.Fusion.Common." ++ func ++ ": " ++ msg + +emptyError :: String -> a +emptyError func = internalError func "Empty input" + +internalError :: String -> a +internalError func = streamError func "Internal error" diff --git a/Data/Text/Internal/Fusion/Size.hs b/Data/Text/Internal/Fusion/Size.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Fusion/Size.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +-- | +-- Module : Data.Text.Internal.Fusion.Internal +-- Copyright : (c) Roman Leshchinskiy 2008, +-- (c) Bryan O'Sullivan 2009 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : portable +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Size hints. + +module Data.Text.Internal.Fusion.Size + ( + Size + , exactly + , exactSize + , maxSize + , unknownSize + , smaller + , larger + , upperBound + , isEmpty + ) where + +#if defined(ASSERTS) +import Control.Exception (assert) +#endif + +data Size = Exact {-# UNPACK #-} !Int -- ^ Exact size. + | Max {-# UNPACK #-} !Int -- ^ Upper bound on size. + | Unknown -- ^ Unknown size. + deriving (Eq, Show) + +exactly :: Size -> Maybe Int +exactly (Exact n) = Just n +exactly _ = Nothing +{-# INLINE exactly #-} + +exactSize :: Int -> Size +exactSize n = +#if defined(ASSERTS) + assert (n >= 0) +#endif + Exact n +{-# INLINE exactSize #-} + +maxSize :: Int -> Size +maxSize n = +#if defined(ASSERTS) + assert (n >= 0) +#endif + Max n +{-# INLINE maxSize #-} + +unknownSize :: Size +unknownSize = Unknown +{-# INLINE unknownSize #-} + +instance Num Size where + (+) = addSize + (-) = subtractSize + (*) = mulSize + + fromInteger = f where f = Exact . fromInteger + {-# INLINE f #-} + +add :: Int -> Int -> Int +add m n | mn >= 0 = mn + | otherwise = overflowError + where mn = m + n +{-# INLINE add #-} + +addSize :: Size -> Size -> Size +addSize (Exact m) (Exact n) = Exact (add m n) +addSize (Exact m) (Max n) = Max (add m n) +addSize (Max m) (Exact n) = Max (add m n) +addSize (Max m) (Max n) = Max (add m n) +addSize _ _ = Unknown +{-# INLINE addSize #-} + +subtractSize :: Size -> Size -> Size +subtractSize (Exact m) (Exact n) = Exact (max (m-n) 0) +subtractSize (Exact m) (Max _) = Max m +subtractSize (Max m) (Exact n) = Max (max (m-n) 0) +subtractSize a@(Max _) (Max _) = a +subtractSize a@(Max _) Unknown = a +subtractSize _ _ = Unknown +{-# INLINE subtractSize #-} + +mul :: Int -> Int -> Int +mul m n + | m <= maxBound `quot` n = m * n + | otherwise = overflowError +{-# INLINE mul #-} + +mulSize :: Size -> Size -> Size +mulSize (Exact m) (Exact n) = Exact (mul m n) +mulSize (Exact m) (Max n) = Max (mul m n) +mulSize (Max m) (Exact n) = Max (mul m n) +mulSize (Max m) (Max n) = Max (mul m n) +mulSize _ _ = Unknown +{-# INLINE mulSize #-} + +-- | Minimum of two size hints. +smaller :: Size -> Size -> Size +smaller (Exact m) (Exact n) = Exact (m `min` n) +smaller (Exact m) (Max n) = Max (m `min` n) +smaller (Exact m) Unknown = Max m +smaller (Max m) (Exact n) = Max (m `min` n) +smaller (Max m) (Max n) = Max (m `min` n) +smaller a@(Max _) Unknown = a +smaller Unknown (Exact n) = Max n +smaller Unknown (Max n) = Max n +smaller Unknown Unknown = Unknown +{-# INLINE smaller #-} + +-- | Maximum of two size hints. +larger :: Size -> Size -> Size +larger (Exact m) (Exact n) = Exact (m `max` n) +larger a@(Exact m) b@(Max n) | m >= n = a + | otherwise = b +larger a@(Max m) b@(Exact n) | n >= m = b + | otherwise = a +larger (Max m) (Max n) = Max (m `max` n) +larger _ _ = Unknown +{-# INLINE larger #-} + +-- | Compute the maximum size from a size hint, if possible. +upperBound :: Int -> Size -> Int +upperBound _ (Exact n) = n +upperBound _ (Max n) = n +upperBound k _ = k +{-# INLINE upperBound #-} + +isEmpty :: Size -> Bool +isEmpty (Exact n) = n <= 0 +isEmpty (Max n) = n <= 0 +isEmpty _ = False +{-# INLINE isEmpty #-} + +overflowError :: Int +overflowError = error "Data.Text.Internal.Fusion.Size: size overflow" diff --git a/Data/Text/Internal/Fusion/Types.hs b/Data/Text/Internal/Fusion/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Fusion/Types.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE BangPatterns, ExistentialQuantification #-} +-- | +-- Module : Data.Text.Internal.Fusion.Types +-- Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009, +-- (c) Jasper Van der Jeugt 2011 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Core stream fusion functionality for text. + +module Data.Text.Internal.Fusion.Types + ( + CC(..) + , M(..) + , M8 + , PairS(..) + , RS(..) + , Step(..) + , Stream(..) + , Switch(..) + , empty + ) where + +import Data.Text.Internal.Fusion.Size +import Data.Word (Word8) + +-- | Specialised tuple for case conversion. +data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char + +-- | Specialised, strict Maybe-like type. +data M a = N + | J !a + +type M8 = M Word8 + +-- Restreaming state. +data RS s + = RS0 !s + | RS1 !s {-# UNPACK #-} !Word8 + | RS2 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 + | RS3 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 + +infixl 2 :*: +data PairS a b = !a :*: !b + -- deriving (Eq, Ord, Show) + +-- | Allow a function over a stream to switch between two states. +data Switch = S1 | S2 + +data Step s a = Done + | Skip !s + | Yield !a !s + +{- +instance (Show a) => Show (Step s a) + where show Done = "Done" + show (Skip _) = "Skip" + show (Yield x _) = "Yield " ++ show x +-} + +instance (Eq a) => Eq (Stream a) where + (==) = eq + +instance (Ord a) => Ord (Stream a) where + compare = cmp + +-- The length hint in a Stream has two roles. If its value is zero, +-- we trust it, and treat the stream as empty. Otherwise, we treat it +-- as a hint: it should usually be accurate, so we use it when +-- unstreaming to decide what size array to allocate. However, the +-- unstreaming functions must be able to cope with the hint being too +-- small or too large. +-- +-- The size hint tries to track the UTF-16 code points in a stream, +-- but often counts the number of characters instead. It can easily +-- undercount if, for instance, a transformed stream contains astral +-- plane characters (those above 0x10000). + +data Stream a = + forall s. Stream + (s -> Step s a) -- stepper function + !s -- current state + !Size -- size hint + +-- | /O(n)/ Determines if two streams are equal. +eq :: (Eq a) => Stream a -> Stream a -> Bool +eq (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2) + where + loop Done Done = True + loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2') + loop (Skip s1') x2 = loop (next1 s1') x2 + loop x1 (Skip s2') = loop x1 (next2 s2') + loop Done _ = False + loop _ Done = False + loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 && + loop (next1 s1') (next2 s2') +{-# INLINE [0] eq #-} + +cmp :: (Ord a) => Stream a -> Stream a -> Ordering +cmp (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2) + where + loop Done Done = EQ + loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2') + loop (Skip s1') x2 = loop (next1 s1') x2 + loop x1 (Skip s2') = loop x1 (next2 s2') + loop Done _ = LT + loop _ Done = GT + loop (Yield x1 s1') (Yield x2 s2') = + case compare x1 x2 of + EQ -> loop (next1 s1') (next2 s2') + other -> other +{-# INLINE [0] cmp #-} + +-- | The empty stream. +empty :: Stream a +empty = Stream next () 0 + where next _ = Done +{-# INLINE [0] empty #-} diff --git a/Data/Text/Internal/IO.hs b/Data/Text/Internal/IO.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/IO.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE BangPatterns, CPP, RecordWildCards #-} +-- | +-- Module : Data.Text.Internal.IO +-- Copyright : (c) 2009, 2010 Bryan O'Sullivan, +-- (c) 2009 Simon Marlow +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Low-level support for text I\/O. + +module Data.Text.Internal.IO + ( + hGetLineWith + , readChunk + ) where + +import qualified Control.Exception as E +import Data.IORef (readIORef, writeIORef) +import Data.Text (Text) +import Data.Text.Internal.Fusion (unstream) +import Data.Text.Internal.Fusion.Types (Step(..), Stream(..)) +import Data.Text.Internal.Fusion.Size (exactSize, maxSize) +import Data.Text.Unsafe (inlinePerformIO) +import Foreign.Storable (peekElemOff) +import GHC.IO.Buffer (Buffer(..), CharBuffer, RawCharBuffer, bufferAdjustL, + bufferElems, charSize, isEmptyBuffer, readCharBuf, + withRawBuffer, writeCharBuf) +import GHC.IO.Handle.Internals (ioe_EOF, readTextDevice, wantReadableHandle_) +import GHC.IO.Handle.Types (Handle__(..), Newline(..)) +import System.IO (Handle) +import System.IO.Error (isEOFError) +import qualified Data.Text as T + +-- | Read a single line of input from a handle, constructing a list of +-- decoded chunks as we go. When we're done, transform them into the +-- destination type. +hGetLineWith :: ([Text] -> t) -> Handle -> IO t +hGetLineWith f h = wantReadableHandle_ "hGetLine" h go + where + go hh@Handle__{..} = readIORef haCharBuffer >>= fmap f . hGetLineLoop hh [] + +hGetLineLoop :: Handle__ -> [Text] -> CharBuffer -> IO [Text] +hGetLineLoop hh@Handle__{..} = go where + go ts buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } = do + let findEOL raw r | r == w = return (False, w) + | otherwise = do + (c,r') <- readCharBuf raw r + if c == '\n' + then return (True, r) + else findEOL raw r' + (eol, off) <- findEOL raw0 r0 + (t,r') <- if haInputNL == CRLF + then unpack_nl raw0 r0 off + else do t <- unpack raw0 r0 off + return (t,off) + if eol + then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf) + return $ reverse (t:ts) + else do + let buf1 = bufferAdjustL r' buf + maybe_buf <- maybeFillReadBuffer hh buf1 + case maybe_buf of + -- Nothing indicates we caught an EOF, and we may have a + -- partial line to return. + Nothing -> do + -- we reached EOF. There might be a lone \r left + -- in the buffer, so check for that and + -- append it to the line if necessary. + let pre | isEmptyBuffer buf1 = T.empty + | otherwise = T.singleton '\r' + writeIORef haCharBuffer buf1{ bufL=0, bufR=0 } + let str = reverse . filter (not . T.null) $ pre:t:ts + if null str + then ioe_EOF + else return str + Just new_buf -> go (t:ts) new_buf + +-- This function is lifted almost verbatim from GHC.IO.Handle.Text. +maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer) +maybeFillReadBuffer handle_ buf + = E.catch (Just `fmap` getSomeCharacters handle_ buf) $ \e -> + if isEOFError e + then return Nothing + else ioError e + +unpack :: RawCharBuffer -> Int -> Int -> IO Text +unpack !buf !r !w + | charSize /= 4 = sizeError "unpack" + | r >= w = return T.empty + | otherwise = withRawBuffer buf go + where + go pbuf = return $! unstream (Stream next r (exactSize (w-r))) + where + next !i | i >= w = Done + | otherwise = Yield (ix i) (i+1) + ix i = inlinePerformIO $ peekElemOff pbuf i + +unpack_nl :: RawCharBuffer -> Int -> Int -> IO (Text, Int) +unpack_nl !buf !r !w + | charSize /= 4 = sizeError "unpack_nl" + | r >= w = return (T.empty, 0) + | otherwise = withRawBuffer buf $ go + where + go pbuf = do + let !t = unstream (Stream next r (maxSize (w-r))) + w' = w - 1 + return $ if ix w' == '\r' + then (t,w') + else (t,w) + where + next !i | i >= w = Done + | c == '\r' = let i' = i + 1 + in if i' < w + then if ix i' == '\n' + then Yield '\n' (i+2) + else Yield '\n' i' + else Done + | otherwise = Yield c (i+1) + where c = ix i + ix i = inlinePerformIO $ peekElemOff pbuf i + +-- This function is completely lifted from GHC.IO.Handle.Text. +getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer +getSomeCharacters handle_@Handle__{..} buf@Buffer{..} = + case bufferElems buf of + -- buffer empty: read some more + 0 -> {-# SCC "readTextDevice" #-} readTextDevice handle_ buf + + -- if the buffer has a single '\r' in it and we're doing newline + -- translation: read some more + 1 | haInputNL == CRLF -> do + (c,_) <- readCharBuf bufRaw bufL + if c == '\r' + then do -- shuffle the '\r' to the beginning. This is only safe + -- if we're about to call readTextDevice, otherwise it + -- would mess up flushCharBuffer. + -- See [note Buffer Flushing], GHC.IO.Handle.Types + _ <- writeCharBuf bufRaw 0 '\r' + let buf' = buf{ bufL=0, bufR=1 } + readTextDevice handle_ buf' + else do + return buf + + -- buffer has some chars in it already: just return it + _otherwise -> {-# SCC "otherwise" #-} return buf + +-- | Read a single chunk of strict text from a buffer. Used by both +-- the strict and lazy implementations of hGetContents. +readChunk :: Handle__ -> CharBuffer -> IO Text +readChunk hh@Handle__{..} buf = do + buf'@Buffer{..} <- getSomeCharacters hh buf + (t,r) <- if haInputNL == CRLF + then unpack_nl bufRaw bufL bufR + else do t <- unpack bufRaw bufL bufR + return (t,bufR) + writeIORef haCharBuffer (bufferAdjustL r buf') + return t + +sizeError :: String -> a +sizeError loc = error $ "Data.Text.IO." ++ loc ++ ": bad internal buffer size" diff --git a/Data/Text/Internal/Lazy.hs b/Data/Text/Internal/Lazy.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Lazy.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} +-- | +-- Module : Data.Text.Internal.Lazy +-- Copyright : (c) 2009, 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- A module containing private 'Text' internals. This exposes the +-- 'Text' representation and low level construction functions. +-- Modules which extend the 'Text' system may need to use this module. + +module Data.Text.Internal.Lazy + ( + Text(..) + , chunk + , empty + , foldrChunks + , foldlChunks + -- * Data type invariant and abstraction functions + + -- $invariant + , strictInvariant + , lazyInvariant + , showStructure + + -- * Chunk allocation sizes + , defaultChunkSize + , smallChunkSize + , chunkOverhead + ) where + +import Data.Text () +import Data.Text.Internal.Unsafe.Shift (shiftL) +import Data.Typeable (Typeable) +import Foreign.Storable (sizeOf) +import qualified Data.Text.Internal as T + +data Text = Empty + | Chunk {-# UNPACK #-} !T.Text Text + deriving (Typeable) + +-- $invariant +-- +-- The data type invariant for lazy 'Text': Every 'Text' is either 'Empty' or +-- consists of non-null 'T.Text's. All functions must preserve this, +-- and the QC properties must check this. + +-- | Check the invariant strictly. +strictInvariant :: Text -> Bool +strictInvariant Empty = True +strictInvariant x@(Chunk (T.Text _ _ len) cs) + | len > 0 = strictInvariant cs + | otherwise = error $ "Data.Text.Lazy: invariant violation: " + ++ showStructure x + +-- | Check the invariant lazily. +lazyInvariant :: Text -> Text +lazyInvariant Empty = Empty +lazyInvariant x@(Chunk c@(T.Text _ _ len) cs) + | len > 0 = Chunk c (lazyInvariant cs) + | otherwise = error $ "Data.Text.Lazy: invariant violation: " + ++ showStructure x + +-- | Display the internal structure of a lazy 'Text'. +showStructure :: Text -> String +showStructure Empty = "Empty" +showStructure (Chunk t Empty) = "Chunk " ++ show t ++ " Empty" +showStructure (Chunk t ts) = + "Chunk " ++ show t ++ " (" ++ showStructure ts ++ ")" + +-- | Smart constructor for 'Chunk'. Guarantees the data type invariant. +chunk :: T.Text -> Text -> Text +{-# INLINE chunk #-} +chunk t@(T.Text _ _ len) ts | len == 0 = ts + | otherwise = Chunk t ts + +-- | Smart constructor for 'Empty'. +empty :: Text +{-# INLINE [0] empty #-} +empty = Empty + +-- | Consume the chunks of a lazy 'Text' with a natural right fold. +foldrChunks :: (T.Text -> a -> a) -> a -> Text -> a +foldrChunks f z = go + where go Empty = z + go (Chunk c cs) = f c (go cs) +{-# INLINE foldrChunks #-} + +-- | Consume the chunks of a lazy 'Text' with a strict, tail-recursive, +-- accumulating left fold. +foldlChunks :: (a -> T.Text -> a) -> a -> Text -> a +foldlChunks f z = go z + where go !a Empty = a + go !a (Chunk c cs) = go (f a c) cs +{-# INLINE foldlChunks #-} + +-- | Currently set to 16 KiB, less the memory management overhead. +defaultChunkSize :: Int +defaultChunkSize = 16384 - chunkOverhead +{-# INLINE defaultChunkSize #-} + +-- | Currently set to 128 bytes, less the memory management overhead. +smallChunkSize :: Int +smallChunkSize = 128 - chunkOverhead +{-# INLINE smallChunkSize #-} + +-- | The memory management overhead. Currently this is tuned for GHC only. +chunkOverhead :: Int +chunkOverhead = sizeOf (undefined :: Int) `shiftL` 1 +{-# INLINE chunkOverhead #-} diff --git a/Data/Text/Internal/Lazy/Encoding/Fusion.hs b/Data/Text/Internal/Lazy/Encoding/Fusion.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Lazy/Encoding/Fusion.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE BangPatterns, CPP, Rank2Types #-} + +-- | +-- Module : Data.Text.Lazy.Encoding.Fusion +-- Copyright : (c) 2009, 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : portable +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Fusible 'Stream'-oriented functions for converting between lazy +-- 'Text' and several common encodings. + +module Data.Text.Internal.Lazy.Encoding.Fusion + ( + -- * Streaming + -- streamASCII + streamUtf8 + , streamUtf16LE + , streamUtf16BE + , streamUtf32LE + , streamUtf32BE + + -- * Unstreaming + , unstream + + , module Data.Text.Internal.Encoding.Fusion.Common + ) where + +import Data.ByteString.Lazy.Internal (ByteString(..), defaultChunkSize) +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import Data.Text.Internal.Encoding.Fusion.Common +import Data.Text.Encoding.Error +import Data.Text.Internal.Fusion (Step(..), Stream(..)) +import Data.Text.Internal.Fusion.Size +import Data.Text.Internal.Unsafe.Char (unsafeChr, unsafeChr8, unsafeChr32) +import Data.Text.Internal.Unsafe.Shift (shiftL) +import Data.Word (Word8, Word16, Word32) +import qualified Data.Text.Internal.Encoding.Utf8 as U8 +import qualified Data.Text.Internal.Encoding.Utf16 as U16 +import qualified Data.Text.Internal.Encoding.Utf32 as U32 +import Data.Text.Unsafe (unsafeDupablePerformIO) +import Foreign.ForeignPtr (withForeignPtr, ForeignPtr) +import Foreign.Storable (pokeByteOff) +import Data.ByteString.Internal (mallocByteString, memcpy) +#if defined(ASSERTS) +import Control.Exception (assert) +#endif +import qualified Data.ByteString.Internal as B + +data S = S0 + | S1 {-# UNPACK #-} !Word8 + | S2 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 + | S3 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 + | S4 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 + +data T = T !ByteString !S {-# UNPACK #-} !Int + +-- | /O(n)/ Convert a lazy 'ByteString' into a 'Stream Char', using +-- UTF-8 encoding. +streamUtf8 :: OnDecodeError -> ByteString -> Stream Char +streamUtf8 onErr bs0 = Stream next (T bs0 S0 0) unknownSize + where + next (T bs@(Chunk ps _) S0 i) + | i < len && U8.validate1 a = + Yield (unsafeChr8 a) (T bs S0 (i+1)) + | i + 1 < len && U8.validate2 a b = + Yield (U8.chr2 a b) (T bs S0 (i+2)) + | i + 2 < len && U8.validate3 a b c = + Yield (U8.chr3 a b c) (T bs S0 (i+3)) + | i + 3 < len && U8.validate4 a b c d = + Yield (U8.chr4 a b c d) (T bs S0 (i+4)) + where len = B.length ps + a = B.unsafeIndex ps i + b = B.unsafeIndex ps (i+1) + c = B.unsafeIndex ps (i+2) + d = B.unsafeIndex ps (i+3) + next st@(T bs s i) = + case s of + S1 a | U8.validate1 a -> Yield (unsafeChr8 a) es + S2 a b | U8.validate2 a b -> Yield (U8.chr2 a b) es + S3 a b c | U8.validate3 a b c -> Yield (U8.chr3 a b c) es + S4 a b c d | U8.validate4 a b c d -> Yield (U8.chr4 a b c d) es + _ -> consume st + where es = T bs S0 i + consume (T bs@(Chunk ps rest) s i) + | i >= B.length ps = consume (T rest s 0) + | otherwise = + case s of + S0 -> next (T bs (S1 x) (i+1)) + S1 a -> next (T bs (S2 a x) (i+1)) + S2 a b -> next (T bs (S3 a b x) (i+1)) + S3 a b c -> next (T bs (S4 a b c x) (i+1)) + S4 a b c d -> decodeError "streamUtf8" "UTF-8" onErr (Just a) + (T bs (S3 b c d) (i+1)) + where x = B.unsafeIndex ps i + consume (T Empty S0 _) = Done + consume st = decodeError "streamUtf8" "UTF-8" onErr Nothing st +{-# INLINE [0] streamUtf8 #-} + +-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little +-- endian UTF-16 encoding. +streamUtf16LE :: OnDecodeError -> ByteString -> Stream Char +streamUtf16LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize + where + next (T bs@(Chunk ps _) S0 i) + | i + 1 < len && U16.validate1 x1 = + Yield (unsafeChr x1) (T bs S0 (i+2)) + | i + 3 < len && U16.validate2 x1 x2 = + Yield (U16.chr2 x1 x2) (T bs S0 (i+4)) + where len = B.length ps + x1 = c (idx i) (idx (i + 1)) + x2 = c (idx (i + 2)) (idx (i + 3)) + c w1 w2 = w1 + (w2 `shiftL` 8) + idx = fromIntegral . B.unsafeIndex ps :: Int -> Word16 + next st@(T bs s i) = + case s of + S2 w1 w2 | U16.validate1 (c w1 w2) -> + Yield (unsafeChr (c w1 w2)) es + S4 w1 w2 w3 w4 | U16.validate2 (c w1 w2) (c w3 w4) -> + Yield (U16.chr2 (c w1 w2) (c w3 w4)) es + _ -> consume st + where es = T bs S0 i + c :: Word8 -> Word8 -> Word16 + c w1 w2 = fromIntegral w1 + (fromIntegral w2 `shiftL` 8) + consume (T bs@(Chunk ps rest) s i) + | i >= B.length ps = consume (T rest s 0) + | otherwise = + case s of + S0 -> next (T bs (S1 x) (i+1)) + S1 w1 -> next (T bs (S2 w1 x) (i+1)) + S2 w1 w2 -> next (T bs (S3 w1 w2 x) (i+1)) + S3 w1 w2 w3 -> next (T bs (S4 w1 w2 w3 x) (i+1)) + S4 w1 w2 w3 w4 -> decodeError "streamUtf16LE" "UTF-16LE" onErr (Just w1) + (T bs (S3 w2 w3 w4) (i+1)) + where x = B.unsafeIndex ps i + consume (T Empty S0 _) = Done + consume st = decodeError "streamUtf16LE" "UTF-16LE" onErr Nothing st +{-# INLINE [0] streamUtf16LE #-} + +-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big +-- endian UTF-16 encoding. +streamUtf16BE :: OnDecodeError -> ByteString -> Stream Char +streamUtf16BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize + where + next (T bs@(Chunk ps _) S0 i) + | i + 1 < len && U16.validate1 x1 = + Yield (unsafeChr x1) (T bs S0 (i+2)) + | i + 3 < len && U16.validate2 x1 x2 = + Yield (U16.chr2 x1 x2) (T bs S0 (i+4)) + where len = B.length ps + x1 = c (idx i) (idx (i + 1)) + x2 = c (idx (i + 2)) (idx (i + 3)) + c w1 w2 = (w1 `shiftL` 8) + w2 + idx = fromIntegral . B.unsafeIndex ps :: Int -> Word16 + next st@(T bs s i) = + case s of + S2 w1 w2 | U16.validate1 (c w1 w2) -> + Yield (unsafeChr (c w1 w2)) es + S4 w1 w2 w3 w4 | U16.validate2 (c w1 w2) (c w3 w4) -> + Yield (U16.chr2 (c w1 w2) (c w3 w4)) es + _ -> consume st + where es = T bs S0 i + c :: Word8 -> Word8 -> Word16 + c w1 w2 = (fromIntegral w1 `shiftL` 8) + fromIntegral w2 + consume (T bs@(Chunk ps rest) s i) + | i >= B.length ps = consume (T rest s 0) + | otherwise = + case s of + S0 -> next (T bs (S1 x) (i+1)) + S1 w1 -> next (T bs (S2 w1 x) (i+1)) + S2 w1 w2 -> next (T bs (S3 w1 w2 x) (i+1)) + S3 w1 w2 w3 -> next (T bs (S4 w1 w2 w3 x) (i+1)) + S4 w1 w2 w3 w4 -> decodeError "streamUtf16BE" "UTF-16BE" onErr (Just w1) + (T bs (S3 w2 w3 w4) (i+1)) + where x = B.unsafeIndex ps i + consume (T Empty S0 _) = Done + consume st = decodeError "streamUtf16BE" "UTF-16BE" onErr Nothing st +{-# INLINE [0] streamUtf16BE #-} + +-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big +-- endian UTF-32 encoding. +streamUtf32BE :: OnDecodeError -> ByteString -> Stream Char +streamUtf32BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize + where + next (T bs@(Chunk ps _) S0 i) + | i + 3 < len && U32.validate x = + Yield (unsafeChr32 x) (T bs S0 (i+4)) + where len = B.length ps + x = shiftL x1 24 + shiftL x2 16 + shiftL x3 8 + x4 + x1 = idx i + x2 = idx (i+1) + x3 = idx (i+2) + x4 = idx (i+3) + idx = fromIntegral . B.unsafeIndex ps :: Int -> Word32 + next st@(T bs s i) = + case s of + S4 w1 w2 w3 w4 | U32.validate (c w1 w2 w3 w4) -> + Yield (unsafeChr32 (c w1 w2 w3 w4)) es + _ -> consume st + where es = T bs S0 i + c :: Word8 -> Word8 -> Word8 -> Word8 -> Word32 + c w1 w2 w3 w4 = shifted + where + shifted = shiftL x1 24 + shiftL x2 16 + shiftL x3 8 + x4 + x1 = fromIntegral w1 + x2 = fromIntegral w2 + x3 = fromIntegral w3 + x4 = fromIntegral w4 + consume (T bs@(Chunk ps rest) s i) + | i >= B.length ps = consume (T rest s 0) + | otherwise = + case s of + S0 -> next (T bs (S1 x) (i+1)) + S1 w1 -> next (T bs (S2 w1 x) (i+1)) + S2 w1 w2 -> next (T bs (S3 w1 w2 x) (i+1)) + S3 w1 w2 w3 -> next (T bs (S4 w1 w2 w3 x) (i+1)) + S4 w1 w2 w3 w4 -> decodeError "streamUtf32BE" "UTF-32BE" onErr (Just w1) + (T bs (S3 w2 w3 w4) (i+1)) + where x = B.unsafeIndex ps i + consume (T Empty S0 _) = Done + consume st = decodeError "streamUtf32BE" "UTF-32BE" onErr Nothing st +{-# INLINE [0] streamUtf32BE #-} + +-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little +-- endian UTF-32 encoding. +streamUtf32LE :: OnDecodeError -> ByteString -> Stream Char +streamUtf32LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize + where + next (T bs@(Chunk ps _) S0 i) + | i + 3 < len && U32.validate x = + Yield (unsafeChr32 x) (T bs S0 (i+4)) + where len = B.length ps + x = shiftL x4 24 + shiftL x3 16 + shiftL x2 8 + x1 + x1 = idx i + x2 = idx (i+1) + x3 = idx (i+2) + x4 = idx (i+3) + idx = fromIntegral . B.unsafeIndex ps :: Int -> Word32 + next st@(T bs s i) = + case s of + S4 w1 w2 w3 w4 | U32.validate (c w1 w2 w3 w4) -> + Yield (unsafeChr32 (c w1 w2 w3 w4)) es + _ -> consume st + where es = T bs S0 i + c :: Word8 -> Word8 -> Word8 -> Word8 -> Word32 + c w1 w2 w3 w4 = shifted + where + shifted = shiftL x4 24 + shiftL x3 16 + shiftL x2 8 + x1 + x1 = fromIntegral w1 + x2 = fromIntegral w2 + x3 = fromIntegral w3 + x4 = fromIntegral w4 + consume (T bs@(Chunk ps rest) s i) + | i >= B.length ps = consume (T rest s 0) + | otherwise = + case s of + S0 -> next (T bs (S1 x) (i+1)) + S1 w1 -> next (T bs (S2 w1 x) (i+1)) + S2 w1 w2 -> next (T bs (S3 w1 w2 x) (i+1)) + S3 w1 w2 w3 -> next (T bs (S4 w1 w2 w3 x) (i+1)) + S4 w1 w2 w3 w4 -> decodeError "streamUtf32LE" "UTF-32LE" onErr (Just w1) + (T bs (S3 w2 w3 w4) (i+1)) + where x = B.unsafeIndex ps i + consume (T Empty S0 _) = Done + consume st = decodeError "streamUtf32LE" "UTF-32LE" onErr Nothing st +{-# INLINE [0] streamUtf32LE #-} + +-- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'. +unstreamChunks :: Int -> Stream Word8 -> ByteString +unstreamChunks chunkSize (Stream next s0 len0) = chunk s0 (upperBound 4 len0) + where chunk s1 len1 = unsafeDupablePerformIO $ do + let len = max 4 (min len1 chunkSize) + mallocByteString len >>= loop len 0 s1 + where + loop !n !off !s fp = case next s of + Done | off == 0 -> return Empty + | otherwise -> return $! Chunk (trimUp fp off) Empty + Skip s' -> loop n off s' fp + Yield x s' + | off == chunkSize -> do + let !newLen = n - off + return $! Chunk (trimUp fp off) (chunk s newLen) + | off == n -> realloc fp n off s' x + | otherwise -> do + withForeignPtr fp $ \p -> pokeByteOff p off x + loop n (off+1) s' fp + {-# NOINLINE realloc #-} + realloc fp n off s x = do + let n' = min (n+n) chunkSize + fp' <- copy0 fp n n' + withForeignPtr fp' $ \p -> pokeByteOff p off x + loop n' (off+1) s fp' + trimUp fp off = B.PS fp 0 off + copy0 :: ForeignPtr Word8 -> Int -> Int -> IO (ForeignPtr Word8) + copy0 !src !srcLen !destLen = +#if defined(ASSERTS) + assert (srcLen <= destLen) $ +#endif + do + dest <- mallocByteString destLen + withForeignPtr src $ \src' -> + withForeignPtr dest $ \dest' -> + memcpy dest' src' (fromIntegral srcLen) + return dest + +-- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'. +unstream :: Stream Word8 -> ByteString +unstream = unstreamChunks defaultChunkSize + +decodeError :: forall s. String -> String -> OnDecodeError -> Maybe Word8 + -> s -> Step s Char +decodeError func kind onErr mb i = + case onErr desc mb of + Nothing -> Skip i + Just c -> Yield c i + where desc = "Data.Text.Lazy.Encoding.Fusion." ++ func ++ ": Invalid " ++ + kind ++ " stream" diff --git a/Data/Text/Internal/Lazy/Fusion.hs b/Data/Text/Internal/Lazy/Fusion.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Lazy/Fusion.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Data.Text.Lazy.Fusion +-- Copyright : (c) 2009, 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Core stream fusion functionality for text. + +module Data.Text.Internal.Lazy.Fusion + ( + stream + , unstream + , unstreamChunks + , length + , unfoldrN + , index + , countChar + ) where + +import Prelude hiding (length) +import qualified Data.Text.Internal.Fusion.Common as S +import Control.Monad.ST (runST) +import Data.Text.Internal.Fusion.Types +import Data.Text.Internal.Fusion.Size (isEmpty, unknownSize) +import Data.Text.Internal.Lazy +import qualified Data.Text.Internal as I +import qualified Data.Text.Array as A +import Data.Text.Internal.Unsafe.Char (unsafeWrite) +import Data.Text.Internal.Unsafe.Shift (shiftL) +import Data.Text.Unsafe (Iter(..), iter) +import Data.Int (Int64) + +default(Int64) + +-- | /O(n)/ Convert a 'Text' into a 'Stream Char'. +stream :: Text -> Stream Char +stream text = Stream next (text :*: 0) unknownSize + where + next (Empty :*: _) = Done + next (txt@(Chunk t@(I.Text _ _ len) ts) :*: i) + | i >= len = next (ts :*: 0) + | otherwise = Yield c (txt :*: i+d) + where Iter c d = iter t i +{-# INLINE [0] stream #-} + +-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using the given +-- chunk size. +unstreamChunks :: Int -> Stream Char -> Text +unstreamChunks !chunkSize (Stream next s0 len0) + | isEmpty len0 = Empty + | otherwise = outer s0 + where + outer so = {-# SCC "unstreamChunks/outer" #-} + case next so of + Done -> Empty + Skip s' -> outer s' + Yield x s' -> runST $ do + a <- A.new unknownLength + unsafeWrite a 0 x >>= inner a unknownLength s' + where unknownLength = 4 + where + inner marr !len s !i + | i + 1 >= chunkSize = finish marr i s + | i + 1 >= len = {-# SCC "unstreamChunks/resize" #-} do + let newLen = min (len `shiftL` 1) chunkSize + marr' <- A.new newLen + A.copyM marr' 0 marr 0 len + inner marr' newLen s i + | otherwise = + {-# SCC "unstreamChunks/inner" #-} + case next s of + Done -> finish marr i s + Skip s' -> inner marr len s' i + Yield x s' -> do d <- unsafeWrite marr i x + inner marr len s' (i+d) + finish marr len s' = do + arr <- A.unsafeFreeze marr + return (I.Text arr 0 len `Chunk` outer s') +{-# INLINE [0] unstreamChunks #-} + +-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using +-- 'defaultChunkSize'. +unstream :: Stream Char -> Text +unstream = unstreamChunks defaultChunkSize +{-# INLINE [0] unstream #-} + +-- | /O(n)/ Returns the number of characters in a text. +length :: Stream Char -> Int64 +length = S.lengthI +{-# INLINE[0] length #-} + +{-# RULES "LAZY STREAM stream/unstream fusion" forall s. + stream (unstream s) = s #-} + +-- | /O(n)/ Like 'unfoldr', '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 :: Int64 -> (a -> Maybe (Char,a)) -> a -> Stream Char +unfoldrN n = S.unfoldrNI n +{-# INLINE [0] unfoldrN #-} + +-- | /O(n)/ stream index (subscript) operator, starting from 0. +index :: Stream Char -> Int64 -> Char +index = S.indexI +{-# INLINE [0] index #-} + +-- | /O(n)/ The 'count' function returns the number of times the query +-- element appears in the given stream. +countChar :: Char -> Stream Char -> Int64 +countChar = S.countCharI +{-# INLINE [0] countChar #-} diff --git a/Data/Text/Internal/Lazy/Search.hs b/Data/Text/Internal/Lazy/Search.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Lazy/Search.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} + +-- | +-- Module : Data.Text.Lazy.Search +-- Copyright : (c) 2009, 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Fast substring search for lazy 'Text', based on work by Boyer, +-- Moore, Horspool, Sunday, and Lundh. Adapted from the strict +-- implementation. + +module Data.Text.Internal.Lazy.Search + ( + indices + ) where + +import qualified Data.Text.Array as A +import Data.Int (Int64) +import Data.Word (Word16, Word64) +import qualified Data.Text.Internal as T +import Data.Text.Internal.Fusion.Types (PairS(..)) +import Data.Text.Internal.Lazy (Text(..), foldlChunks) +import Data.Bits ((.|.), (.&.)) +import Data.Text.Internal.Unsafe.Shift (shiftL) + +-- | /O(n+m)/ Find the offsets of all non-overlapping indices of +-- @needle@ within @haystack@. +-- +-- This function is strict in @needle@, and lazy (as far as possible) +-- in the chunks of @haystack@. +-- +-- In (unlikely) bad cases, this algorithm's complexity degrades +-- towards /O(n*m)/. +indices :: Text -- ^ Substring to search for (@needle@) + -> Text -- ^ Text to search in (@haystack@) + -> [Int64] +indices needle@(Chunk n ns) _haystack@(Chunk k ks) + | nlen <= 0 = [] + | nlen == 1 = indicesOne (nindex 0) 0 k ks + | otherwise = advance k ks 0 0 + where + advance x@(T.Text _ _ l) xs = scan + where + scan !g !i + | i >= m = case xs of + Empty -> [] + Chunk y ys -> advance y ys g (i-m) + | lackingHay (i + nlen) x xs = [] + | c == z && candidateMatch 0 = g : scan (g+nlen) (i+nlen) + | otherwise = scan (g+delta) (i+delta) + where + m = fromIntegral l + c = hindex (i + nlast) + delta | nextInPattern = nlen + 1 + | c == z = skip + 1 + | otherwise = 1 + nextInPattern = mask .&. swizzle (hindex (i+nlen)) == 0 + candidateMatch !j + | j >= nlast = True + | hindex (i+j) /= nindex j = False + | otherwise = candidateMatch (j+1) + hindex = index x xs + nlen = wordLength needle + nlast = nlen - 1 + nindex = index n ns + z = foldlChunks fin 0 needle + where fin _ (T.Text farr foff flen) = A.unsafeIndex farr (foff+flen-1) + (mask :: Word64) :*: skip = buildTable n ns 0 0 0 (nlen-2) + swizzle w = 1 `shiftL` (fromIntegral w .&. 0x3f) + buildTable (T.Text xarr xoff xlen) xs = go + where + go !(g::Int64) !i !msk !skp + | i >= xlast = case xs of + Empty -> (msk .|. swizzle z) :*: skp + Chunk y ys -> buildTable y ys g 0 msk' skp' + | otherwise = go (g+1) (i+1) msk' skp' + where c = A.unsafeIndex xarr (xoff+i) + msk' = msk .|. swizzle c + skp' | c == z = nlen - g - 2 + | otherwise = skp + xlast = xlen - 1 + -- | Check whether an attempt to index into the haystack at the + -- given offset would fail. + lackingHay q = go 0 + where + go p (T.Text _ _ l) ps = p' < q && case ps of + Empty -> True + Chunk r rs -> go p' r rs + where p' = p + fromIntegral l +indices _ _ = [] + +-- | Fast index into a partly unpacked 'Text'. We take into account +-- the possibility that the caller might try to access one element +-- past the end. +index :: T.Text -> Text -> Int64 -> Word16 +index (T.Text arr off len) xs !i + | j < len = A.unsafeIndex arr (off+j) + | otherwise = case xs of + Empty + -- out of bounds, but legal + | j == len -> 0 + -- should never happen, due to lackingHay above + | otherwise -> emptyError "index" + Chunk c cs -> index c cs (i-fromIntegral len) + where j = fromIntegral i + +-- | A variant of 'indices' that scans linearly for a single 'Word16'. +indicesOne :: Word16 -> Int64 -> T.Text -> Text -> [Int64] +indicesOne c = chunk + where + chunk !i (T.Text oarr ooff olen) os = go 0 + where + go h | h >= olen = case os of + Empty -> [] + Chunk y ys -> chunk (i+fromIntegral olen) y ys + | on == c = i + fromIntegral h : go (h+1) + | otherwise = go (h+1) + where on = A.unsafeIndex oarr (ooff+h) + +-- | The number of 'Word16' values in a 'Text'. +wordLength :: Text -> Int64 +wordLength = foldlChunks sumLength 0 + where sumLength i (T.Text _ _ l) = i + fromIntegral l + +emptyError :: String -> a +emptyError fun = error ("Data.Text.Lazy.Search." ++ fun ++ ": empty input") diff --git a/Data/Text/Internal/Private.hs b/Data/Text/Internal/Private.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Private.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-} + +-- | +-- Module : Data.Text.Internal.Private +-- Copyright : (c) 2011 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC + +module Data.Text.Internal.Private + ( + runText + , span_ + ) where + +import Control.Monad.ST (ST, runST) +import Data.Text.Internal (Text(..), textP) +import Data.Text.Unsafe (Iter(..), iter) +import qualified Data.Text.Array as A + +span_ :: (Char -> Bool) -> Text -> (# Text, Text #) +span_ p t@(Text arr off len) = (# hd,tl #) + where hd = textP arr off k + tl = textP arr (off+k) (len-k) + !k = loop 0 + loop !i | i < len && p c = loop (i+d) + | otherwise = i + where Iter c d = iter t i +{-# INLINE span_ #-} + +runText :: (forall s. (A.MArray s -> Int -> ST s Text) -> ST s Text) -> Text +runText act = runST (act $ \ !marr !len -> do + arr <- A.unsafeFreeze marr + return $! textP arr 0 len) +{-# INLINE runText #-} diff --git a/Data/Text/Internal/Search.hs b/Data/Text/Internal/Search.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Search.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} + +-- | +-- Module : Data.Text.Internal.Search +-- Copyright : (c) Bryan O'Sullivan 2009 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- Fast substring search for 'Text', based on work by Boyer, Moore, +-- Horspool, Sunday, and Lundh. +-- +-- References: +-- +-- * R. S. Boyer, J. S. Moore: A Fast String Searching Algorithm. +-- Communications of the ACM, 20, 10, 762-772 (1977) +-- +-- * R. N. Horspool: Practical Fast Searching in Strings. Software - +-- Practice and Experience 10, 501-506 (1980) +-- +-- * D. M. Sunday: A Very Fast Substring Search Algorithm. +-- Communications of the ACM, 33, 8, 132-142 (1990) +-- +-- * F. Lundh: The Fast Search Algorithm. +-- (2006) + +module Data.Text.Internal.Search + ( + indices + ) where + +import qualified Data.Text.Array as A +import Data.Word (Word64) +import Data.Text.Internal (Text(..)) +import Data.Bits ((.|.), (.&.)) +import Data.Text.Internal.Unsafe.Shift (shiftL) + +data T = {-# UNPACK #-} !Word64 :* {-# UNPACK #-} !Int + +-- | /O(n+m)/ Find the offsets of all non-overlapping indices of +-- @needle@ within @haystack@. The offsets returned represent +-- uncorrected indices in the low-level \"needle\" array, to which its +-- offset must be added. +-- +-- In (unlikely) bad cases, this algorithm's complexity degrades +-- towards /O(n*m)/. +indices :: Text -- ^ Substring to search for (@needle@) + -> Text -- ^ Text to search in (@haystack@) + -> [Int] +indices _needle@(Text narr noff nlen) _haystack@(Text harr hoff hlen) + | nlen == 1 = scanOne (nindex 0) + | nlen <= 0 || ldiff < 0 = [] + | otherwise = scan 0 + where + ldiff = hlen - nlen + nlast = nlen - 1 + z = nindex nlast + nindex k = A.unsafeIndex narr (noff+k) + hindex k = A.unsafeIndex harr (hoff+k) + hindex' k | k == hlen = 0 + | otherwise = A.unsafeIndex harr (hoff+k) + buildTable !i !msk !skp + | i >= nlast = (msk .|. swizzle z) :* skp + | otherwise = buildTable (i+1) (msk .|. swizzle c) skp' + where c = nindex i + skp' | c == z = nlen - i - 2 + | otherwise = skp + swizzle k = 1 `shiftL` (fromIntegral k .&. 0x3f) + scan !i + | i > ldiff = [] + | c == z && candidateMatch 0 = i : scan (i + nlen) + | otherwise = scan (i + delta) + where c = hindex (i + nlast) + candidateMatch !j + | j >= nlast = True + | hindex (i+j) /= nindex j = False + | otherwise = candidateMatch (j+1) + delta | nextInPattern = nlen + 1 + | c == z = skip + 1 + | otherwise = 1 + where nextInPattern = mask .&. swizzle (hindex' (i+nlen)) == 0 + !(mask :* skip) = buildTable 0 0 (nlen-2) + scanOne c = loop 0 + where loop !i | i >= hlen = [] + | hindex i == c = i : loop (i+1) + | otherwise = loop (i+1) +{-# INLINE indices #-} diff --git a/Data/Text/Internal/Unsafe.hs b/Data/Text/Internal/Unsafe.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Unsafe.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} +-- | +-- Module : Data.Text.Internal.Unsafe +-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : portable +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- A module containing /unsafe/ operations, for /very very careful/ use +-- in /heavily tested/ code. +module Data.Text.Internal.Unsafe + ( + inlineInterleaveST + , inlinePerformIO + ) where + +import GHC.ST (ST(..)) +#if defined(__GLASGOW_HASKELL__) +import GHC.IO (IO(IO)) +import GHC.Base (realWorld#) +#endif + + +-- | Just like unsafePerformIO, but we inline it. Big performance gains as +-- it exposes lots of things to further inlining. /Very unsafe/. In +-- particular, you should do no memory allocation inside an +-- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@. +-- +{-# INLINE inlinePerformIO #-} +inlinePerformIO :: IO a -> a +#if defined(__GLASGOW_HASKELL__) +inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r +#else +inlinePerformIO = unsafePerformIO +#endif + +-- | Allow an 'ST' computation to be deferred lazily. When passed an +-- action of type 'ST' @s@ @a@, the action will only be performed when +-- the value of @a@ is demanded. +-- +-- This function is identical to the normal unsafeInterleaveST, but is +-- inlined and hence faster. +-- +-- /Note/: This operation is highly unsafe, as it can introduce +-- externally visible non-determinism into an 'ST' action. +inlineInterleaveST :: ST s a -> ST s a +inlineInterleaveST (ST m) = ST $ \ s -> + let r = case m s of (# _, res #) -> res in (# s, r #) +{-# INLINE inlineInterleaveST #-} diff --git a/Data/Text/Internal/Unsafe/Char.hs b/Data/Text/Internal/Unsafe/Char.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Unsafe/Char.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE CPP, MagicHash #-} + +-- | +-- Module : Data.Text.Internal.Unsafe.Char +-- Copyright : (c) 2008, 2009 Tom Harper, +-- (c) 2009, 2010 Bryan O'Sullivan, +-- (c) 2009 Duncan Coutts +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Fast character manipulation functions. +module Data.Text.Internal.Unsafe.Char + ( + ord + , unsafeChr + , unsafeChr8 + , unsafeChr32 + , unsafeWrite + -- , unsafeWriteRev + ) where + +#ifdef ASSERTS +import Control.Exception (assert) +#endif +import Control.Monad.ST (ST) +import Data.Bits ((.&.)) +import Data.Text.Internal.Unsafe.Shift (shiftR) +import GHC.Exts (Char(..), Int(..), chr#, ord#, word2Int#) +import GHC.Word (Word8(..), Word16(..), Word32(..)) +import qualified Data.Text.Array as A + +ord :: Char -> Int +ord (C# c#) = I# (ord# c#) +{-# INLINE ord #-} + +unsafeChr :: Word16 -> Char +unsafeChr (W16# w#) = C# (chr# (word2Int# w#)) +{-# INLINE unsafeChr #-} + +unsafeChr8 :: Word8 -> Char +unsafeChr8 (W8# w#) = C# (chr# (word2Int# w#)) +{-# INLINE unsafeChr8 #-} + +unsafeChr32 :: Word32 -> Char +unsafeChr32 (W32# w#) = C# (chr# (word2Int# w#)) +{-# INLINE unsafeChr32 #-} + +-- | Write a character into the array at the given offset. Returns +-- the number of 'Word16's written. +unsafeWrite :: A.MArray s -> Int -> Char -> ST s Int +unsafeWrite marr i c + | n < 0x10000 = do +#if defined(ASSERTS) + assert (i >= 0) . assert (i < A.length marr) $ return () +#endif + A.unsafeWrite marr i (fromIntegral n) + return 1 + | otherwise = do +#if defined(ASSERTS) + assert (i >= 0) . assert (i < A.length marr - 1) $ return () +#endif + A.unsafeWrite marr i lo + A.unsafeWrite marr (i+1) hi + return 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/Data/Text/Internal/Unsafe/Shift.hs b/Data/Text/Internal/Unsafe/Shift.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Internal/Unsafe/Shift.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE MagicHash #-} + +-- | +-- Module : Data.Text.Internal.Unsafe.Shift +-- Copyright : (c) Bryan O'Sullivan 2009 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Fast, unchecked bit shifting functions. + +module Data.Text.Internal.Unsafe.Shift + ( + UnsafeShift(..) + ) where + +-- import qualified Data.Bits as Bits +import GHC.Base +import GHC.Word + +-- | This is a workaround for poor optimisation in GHC 6.8.2. It +-- fails to notice constant-width shifts, and adds a test and branch +-- to every shift. This imposes about a 10% performance hit. +-- +-- These functions are undefined when the amount being shifted by is +-- greater than the size in bits of a machine Int#. +class UnsafeShift a where + shiftL :: a -> Int -> a + shiftR :: a -> Int -> a + +instance UnsafeShift Word16 where + {-# INLINE shiftL #-} + shiftL (W16# x#) (I# i#) = W16# (narrow16Word# (x# `uncheckedShiftL#` i#)) + + {-# INLINE shiftR #-} + shiftR (W16# x#) (I# i#) = W16# (x# `uncheckedShiftRL#` i#) + +instance UnsafeShift Word32 where + {-# INLINE shiftL #-} + shiftL (W32# x#) (I# i#) = W32# (narrow32Word# (x# `uncheckedShiftL#` i#)) + + {-# INLINE shiftR #-} + shiftR (W32# x#) (I# i#) = W32# (x# `uncheckedShiftRL#` i#) + +instance UnsafeShift Word64 where + {-# INLINE shiftL #-} + shiftL (W64# x#) (I# i#) = W64# (x# `uncheckedShiftL64#` i#) + + {-# INLINE shiftR #-} + shiftR (W64# x#) (I# i#) = W64# (x# `uncheckedShiftRL64#` i#) + +instance UnsafeShift Int where + {-# INLINE shiftL #-} + shiftL (I# x#) (I# i#) = I# (x# `iShiftL#` i#) + + {-# INLINE shiftR #-} + shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#) + +{- +instance UnsafeShift Integer where + {-# INLINE shiftL #-} + shiftL = Bits.shiftL + + {-# INLINE shiftR #-} + shiftR = Bits.shiftR +-} diff --git a/Data/Text/Lazy.hs b/Data/Text/Lazy.hs --- a/Data/Text/Lazy.hs +++ b/Data/Text/Lazy.hs @@ -8,8 +8,7 @@ -- Copyright : (c) 2009, 2010, 2012 Bryan O'Sullivan -- -- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org +-- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- @@ -208,15 +207,15 @@ import Data.String (IsString(..)) import qualified Data.Text as T import qualified Data.Text.Internal as T -import qualified Data.Text.Fusion.Common as S +import qualified Data.Text.Internal.Fusion.Common as S import qualified Data.Text.Unsafe as T -import qualified Data.Text.Lazy.Fusion as S -import Data.Text.Fusion.Internal (PairS(..)) -import Data.Text.Lazy.Fusion (stream, unstream) -import Data.Text.Lazy.Internal (Text(..), chunk, empty, foldlChunks, foldrChunks) +import qualified Data.Text.Internal.Lazy.Fusion as S +import Data.Text.Internal.Fusion.Types (PairS(..)) +import Data.Text.Internal.Lazy.Fusion (stream, unstream) +import Data.Text.Internal.Lazy (Text(..), chunk, empty, foldlChunks, foldrChunks) import Data.Text.Internal (firstf, safe, textP) -import qualified Data.Text.Util as U -import Data.Text.Lazy.Search (indices) +import qualified Data.Text.Internal.Functions as F +import Data.Text.Internal.Lazy.Search (indices) #if __GLASGOW_HASKELL__ >= 702 import qualified GHC.CString as GHC #else @@ -561,7 +560,7 @@ -- 'Text's and concatenates the list after interspersing the first -- argument between each element of the list. intercalate :: Text -> [Text] -> Text -intercalate t = concat . (U.intersperse t) +intercalate t = concat . (F.intersperse t) {-# INLINE intercalate #-} -- | /O(n)/ The 'intersperse' function takes a character and places it diff --git a/Data/Text/Lazy/Builder.hs b/Data/Text/Lazy/Builder.hs --- a/Data/Text/Lazy/Builder.hs +++ b/Data/Text/Lazy/Builder.hs @@ -34,7 +34,7 @@ -- -- > singleton 'a' <> singleton 'b' <> singleton 'c' -- --- since the '<>' from recent versions of 'Data.Monoid' associates +-- since the '<>' from recent versions of 'Data.Monoid' associates -- to the right. ----------------------------------------------------------------------------- @@ -55,4 +55,4 @@ , flush ) where -import Data.Text.Lazy.Builder.Internal +import Data.Text.Internal.Builder diff --git a/Data/Text/Lazy/Builder/Functions.hs b/Data/Text/Lazy/Builder/Functions.hs deleted file mode 100644 --- a/Data/Text/Lazy/Builder/Functions.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE MagicHash #-} - --- | --- Module : Data.Text.Lazy.Builder.Functions --- Copyright : (c) 2011 MailRank, Inc. --- --- License : BSD-style --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : GHC --- --- Useful functions and combinators. - -module Data.Text.Lazy.Builder.Functions - ( - (<>) - , i2d - ) where - -import Data.Monoid (mappend) -import Data.Text.Lazy.Builder (Builder) -import GHC.Base - --- | Unsafe conversion for decimal digits. -{-# INLINE i2d #-} -i2d :: Int -> Char -i2d (I# i#) = C# (chr# (ord# '0'# +# i#)) - --- | The normal 'mappend' function with right associativity instead of --- left. -(<>) :: Builder -> Builder -> Builder -(<>) = mappend -{-# INLINE (<>) #-} - -infixr 4 <> diff --git a/Data/Text/Lazy/Builder/Int.hs b/Data/Text/Lazy/Builder/Int.hs --- a/Data/Text/Lazy/Builder/Int.hs +++ b/Data/Text/Lazy/Builder/Int.hs @@ -22,9 +22,9 @@ import Data.Int (Int8, Int16, Int32, Int64) import Data.Monoid (mempty) import qualified Data.ByteString.Unsafe as B -import Data.Text.Lazy.Builder.Functions ((<>), i2d) -import Data.Text.Lazy.Builder.Internal -import Data.Text.Lazy.Builder.Int.Digits (digits) +import Data.Text.Internal.Builder.Functions ((<>), i2d) +import Data.Text.Internal.Builder +import Data.Text.Internal.Builder.Int.Digits (digits) import Data.Text.Array import Data.Word (Word, Word8, Word16, Word32, Word64) import GHC.Base (quotInt, remInt) diff --git a/Data/Text/Lazy/Builder/Int/Digits.hs b/Data/Text/Lazy/Builder/Int/Digits.hs deleted file mode 100644 --- a/Data/Text/Lazy/Builder/Int/Digits.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Module: Data.Text.Lazy.Builder.Int.Digits --- Copyright: (c) 2013 Bryan O'Sullivan --- License: BSD3 --- Maintainer: Bryan O'Sullivan --- Stability: experimental --- Portability: portable --- --- This module exists because the C preprocessor does things that we --- shall not speak of when confronted with Haskell multiline strings. - -module Data.Text.Lazy.Builder.Int.Digits (digits) where - -import Data.ByteString.Char8 (ByteString) - -digits :: ByteString -digits = "0001020304050607080910111213141516171819\ - \2021222324252627282930313233343536373839\ - \4041424344454647484950515253545556575859\ - \6061626364656667686970717273747576777879\ - \8081828384858687888990919293949596979899" diff --git a/Data/Text/Lazy/Builder/Internal.hs b/Data/Text/Lazy/Builder/Internal.hs deleted file mode 100644 --- a/Data/Text/Lazy/Builder/Internal.hs +++ /dev/null @@ -1,321 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, Rank2Types #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Text.Lazy.Builder.Internal --- Copyright : (c) 2013 Bryan O'Sullivan --- (c) 2010 Johan Tibell --- License : BSD3-style (see LICENSE) --- --- Maintainer : Johan Tibell --- Stability : experimental --- Portability : portable to Hugs and GHC --- --- Efficient construction of lazy @Text@ values. The principal --- operations on a @Builder@ are @singleton@, @fromText@, and --- @fromLazyText@, which construct new builders, and 'mappend', which --- concatenates two builders. --- --- To get maximum performance when building lazy @Text@ values using a --- builder, associate @mappend@ calls to the right. For example, --- prefer --- --- > singleton 'a' `mappend` (singleton 'b' `mappend` singleton 'c') --- --- to --- --- > singleton 'a' `mappend` singleton 'b' `mappend` singleton 'c' --- --- as the latter associates @mappend@ to the left. --- ------------------------------------------------------------------------------ - -module Data.Text.Lazy.Builder.Internal - ( -- * Public API - -- ** The Builder type - Builder - , toLazyText - , toLazyTextWith - - -- ** Constructing Builders - , singleton - , fromText - , fromLazyText - , fromString - - -- ** Flushing the buffer state - , flush - - -- * Internal functions - , append' - , ensureFree - , writeN - ) where - -import Control.Monad.ST (ST, runST) -import Data.Bits ((.&.)) -import Data.Monoid (Monoid(..)) -import Data.Text.Internal (Text(..)) -import Data.Text.Lazy.Internal (smallChunkSize) -import Data.Text.Unsafe (inlineInterleaveST) -import Data.Text.UnsafeChar (ord, unsafeWrite) -import Data.Text.UnsafeShift (shiftR) -import Prelude hiding (map, putChar) - -import qualified Data.String as String -import qualified Data.Text as S -import qualified Data.Text.Array as A -import qualified Data.Text.Lazy as L - ------------------------------------------------------------------------- - --- | A @Builder@ is an efficient way to build lazy @Text@ values. --- There are several functions for constructing builders, but only one --- to inspect them: to extract any data, you have to turn them into --- lazy @Text@ values using @toLazyText@. --- --- Internally, a builder constructs a lazy @Text@ by filling arrays --- piece by piece. As each buffer is filled, it is \'popped\' off, to --- become a new chunk of the resulting lazy @Text@. All this is --- hidden from the user of the @Builder@. -newtype Builder = Builder { - -- Invariant (from Data.Text.Lazy): - -- The lists include no null Texts. - runBuilder :: forall s. (Buffer s -> ST s [S.Text]) - -> Buffer s - -> ST s [S.Text] - } - -instance Monoid Builder where - mempty = empty - {-# INLINE mempty #-} - mappend = append - {-# INLINE mappend #-} - mconcat = foldr mappend mempty - {-# INLINE mconcat #-} - -instance String.IsString Builder where - fromString = fromString - {-# INLINE fromString #-} - -instance Show Builder where - show = show . toLazyText - -instance Eq Builder where - a == b = toLazyText a == toLazyText b - -instance Ord Builder where - a <= b = toLazyText a <= toLazyText b - ------------------------------------------------------------------------- - --- | /O(1)./ The empty @Builder@, satisfying --- --- * @'toLazyText' 'empty' = 'L.empty'@ --- -empty :: Builder -empty = Builder (\ k buf -> k buf) -{-# INLINE empty #-} - --- | /O(1)./ A @Builder@ taking a single character, satisfying --- --- * @'toLazyText' ('singleton' c) = 'L.singleton' c@ --- -singleton :: Char -> Builder -singleton c = writeAtMost 2 $ \ marr o -> - if n < 0x10000 - then A.unsafeWrite marr o (fromIntegral n) >> return 1 - else do - A.unsafeWrite marr o lo - A.unsafeWrite marr (o+1) hi - return 2 - where n = ord c - m = n - 0x10000 - lo = fromIntegral $ (m `shiftR` 10) + 0xD800 - hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00 -{-# INLINE singleton #-} - ------------------------------------------------------------------------- - --- | /O(1)./ The concatenation of two builders, an associative --- operation with identity 'empty', satisfying --- --- * @'toLazyText' ('append' x y) = 'L.append' ('toLazyText' x) ('toLazyText' y)@ --- -append :: Builder -> Builder -> Builder -append (Builder f) (Builder g) = Builder (f . g) -{-# INLINE [0] append #-} - --- TODO: Experiment to find the right threshold. -copyLimit :: Int -copyLimit = 128 - --- This function attempts to merge small @Text@ values instead of --- treating each value as its own chunk. We may not always want this. - --- | /O(1)./ A @Builder@ taking a 'S.Text', satisfying --- --- * @'toLazyText' ('fromText' t) = 'L.fromChunks' [t]@ --- -fromText :: S.Text -> Builder -fromText t@(Text arr off l) - | S.null t = empty - | l <= copyLimit = writeN l $ \marr o -> A.copyI marr o arr off (l+o) - | otherwise = flush `append` mapBuilder (t :) -{-# INLINE [1] fromText #-} - -{-# RULES -"fromText/pack" forall s . - fromText (S.pack s) = fromString s - #-} - --- | /O(1)./ A Builder taking a @String@, satisfying --- --- * @'toLazyText' ('fromString' s) = 'L.fromChunks' [S.pack s]@ --- -fromString :: String -> Builder -fromString str = Builder $ \k (Buffer p0 o0 u0 l0) -> - let loop !marr !o !u !l [] = k (Buffer marr o u l) - loop marr o u l s@(c:cs) - | l <= 1 = do - arr <- A.unsafeFreeze marr - let !t = Text arr o u - marr' <- A.new chunkSize - ts <- inlineInterleaveST (loop marr' 0 0 chunkSize s) - return $ t : ts - | otherwise = do - n <- unsafeWrite marr (o+u) c - loop marr o (u+n) (l-n) cs - in loop p0 o0 u0 l0 str - where - chunkSize = smallChunkSize -{-# INLINE fromString #-} - --- | /O(1)./ A @Builder@ taking a lazy @Text@, satisfying --- --- * @'toLazyText' ('fromLazyText' t) = t@ --- -fromLazyText :: L.Text -> Builder -fromLazyText ts = flush `append` mapBuilder (L.toChunks ts ++) -{-# INLINE fromLazyText #-} - ------------------------------------------------------------------------- - --- Our internal buffer type -data Buffer s = Buffer {-# UNPACK #-} !(A.MArray s) - {-# UNPACK #-} !Int -- offset - {-# UNPACK #-} !Int -- used units - {-# UNPACK #-} !Int -- length left - ------------------------------------------------------------------------- - --- | /O(n)./ Extract a lazy @Text@ from a @Builder@ with a default --- buffer size. The construction work takes place if and when the --- relevant part of the lazy @Text@ is demanded. -toLazyText :: Builder -> L.Text -toLazyText = toLazyTextWith smallChunkSize - --- | /O(n)./ Extract a lazy @Text@ from a @Builder@, using the given --- size for the initial buffer. The construction work takes place if --- and when the relevant part of the lazy @Text@ is demanded. --- --- If the initial buffer is too small to hold all data, subsequent --- buffers will be the default buffer size. -toLazyTextWith :: Int -> Builder -> L.Text -toLazyTextWith chunkSize m = L.fromChunks (runST $ - newBuffer chunkSize >>= runBuilder (m `append` flush) (const (return []))) - --- | /O(1)./ Pop the strict @Text@ we have constructed so far, if any, --- yielding a new chunk in the result lazy @Text@. -flush :: Builder -flush = Builder $ \ k buf@(Buffer p o u l) -> - if u == 0 - then k buf - else do arr <- A.unsafeFreeze p - let !b = Buffer p (o+u) 0 l - !t = Text arr o u - ts <- inlineInterleaveST (k b) - return $! t : ts - ------------------------------------------------------------------------- - --- | Sequence an ST operation on the buffer -withBuffer :: (forall s. Buffer s -> ST s (Buffer s)) -> Builder -withBuffer f = Builder $ \k buf -> f buf >>= k -{-# INLINE withBuffer #-} - --- | Get the size of the buffer -withSize :: (Int -> Builder) -> Builder -withSize f = Builder $ \ k buf@(Buffer _ _ _ l) -> - runBuilder (f l) k buf -{-# INLINE withSize #-} - --- | Map the resulting list of texts. -mapBuilder :: ([S.Text] -> [S.Text]) -> Builder -mapBuilder f = Builder (fmap f .) - ------------------------------------------------------------------------- - --- | Ensure that there are at least @n@ many elements available. -ensureFree :: Int -> Builder -ensureFree !n = withSize $ \ l -> - if n <= l - then empty - else flush `append'` withBuffer (const (newBuffer (max n smallChunkSize))) -{-# INLINE [0] ensureFree #-} - -writeAtMost :: Int -> (forall s. A.MArray s -> Int -> ST s Int) -> Builder -writeAtMost n f = ensureFree n `append'` withBuffer (writeBuffer f) -{-# INLINE [0] writeAtMost #-} - --- | Ensure that @n@ many elements are available, and then use @f@ to --- write some elements into the memory. -writeN :: Int -> (forall s. A.MArray s -> Int -> ST s ()) -> Builder -writeN n f = writeAtMost n (\ p o -> f p o >> return n) -{-# INLINE writeN #-} - -writeBuffer :: (A.MArray s -> Int -> ST s Int) -> Buffer s -> ST s (Buffer s) -writeBuffer f (Buffer p o u l) = do - n <- f p (o+u) - return $! Buffer p o (u+n) (l-n) -{-# INLINE writeBuffer #-} - -newBuffer :: Int -> ST s (Buffer s) -newBuffer size = do - arr <- A.new size - return $! Buffer arr 0 0 size -{-# INLINE newBuffer #-} - ------------------------------------------------------------------------- --- Some nice rules for Builder - --- This function makes GHC understand that 'writeN' and 'ensureFree' --- are *not* recursive in the precense of the rewrite rules below. --- This is not needed with GHC 7+. -append' :: Builder -> Builder -> Builder -append' (Builder f) (Builder g) = Builder (f . g) -{-# INLINE append' #-} - -{-# RULES - -"append/writeAtMost" forall a b (f::forall s. A.MArray s -> Int -> ST s Int) - (g::forall s. A.MArray s -> Int -> ST s Int) ws. - append (writeAtMost a f) (append (writeAtMost b g) ws) = - append (writeAtMost (a+b) (\marr o -> f marr o >>= \ n -> - g marr (o+n) >>= \ m -> - let s = n+m in s `seq` return s)) ws - -"writeAtMost/writeAtMost" forall a b (f::forall s. A.MArray s -> Int -> ST s Int) - (g::forall s. A.MArray s -> Int -> ST s Int). - append (writeAtMost a f) (writeAtMost b g) = - writeAtMost (a+b) (\marr o -> f marr o >>= \ n -> - g marr (o+n) >>= \ m -> - let s = n+m in s `seq` return s) - -"ensureFree/ensureFree" forall a b . - append (ensureFree a) (ensureFree b) = ensureFree (max a b) - -"flush/flush" - append flush flush = flush - - #-} diff --git a/Data/Text/Lazy/Builder/RealFloat.hs b/Data/Text/Lazy/Builder/RealFloat.hs --- a/Data/Text/Lazy/Builder/RealFloat.hs +++ b/Data/Text/Lazy/Builder/RealFloat.hs @@ -19,9 +19,9 @@ import Data.Array.Base (unsafeAt) import Data.Array.IArray -import Data.Text.Lazy.Builder.Functions ((<>), i2d) +import Data.Text.Internal.Builder.Functions ((<>), i2d) import Data.Text.Lazy.Builder.Int (decimal) -import Data.Text.Lazy.Builder.RealFloat.Functions (roundTo) +import Data.Text.Internal.Builder.RealFloat.Functions (roundTo) import Data.Text.Lazy.Builder import qualified Data.Text as T diff --git a/Data/Text/Lazy/Builder/RealFloat/Functions.hs b/Data/Text/Lazy/Builder/RealFloat/Functions.hs deleted file mode 100644 --- a/Data/Text/Lazy/Builder/RealFloat/Functions.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | --- Module: Data.Text.Lazy.Builder.RealFloat.Functions --- Copyright: (c) The University of Glasgow 1994-2002 --- License: see libraries/base/LICENSE - -module Data.Text.Lazy.Builder.RealFloat.Functions - ( - roundTo - ) where - -roundTo :: Int -> [Int] -> (Int,[Int]) -roundTo d is = - case f d is of - x@(0,_) -> x - (1,xs) -> (1, 1:xs) - _ -> error "roundTo: bad Value" - where - f n [] = (0, replicate n 0) - f 0 (x:_) = (if x >= 5 then 1 else 0, []) - f n (i:xs) - | i' == 10 = (1,0:ds) - | otherwise = (0,i':ds) - where - (c,ds) = f (n-1) xs - i' = c + i diff --git a/Data/Text/Lazy/Encoding.hs b/Data/Text/Lazy/Encoding.hs --- a/Data/Text/Lazy/Encoding.hs +++ b/Data/Text/Lazy/Encoding.hs @@ -7,8 +7,7 @@ -- Copyright : (c) 2009, 2010 Bryan O'Sullivan -- -- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org +-- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- @@ -46,19 +45,33 @@ , encodeUtf16BE , encodeUtf32LE , encodeUtf32BE + +#if MIN_VERSION_bytestring(0,10,4) + -- * Encoding Text using ByteString Builders + , encodeUtf8Builder + , encodeUtf8BuilderEscaped +#endif ) where import Control.Exception (evaluate, try) import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode) -import Data.Text.Lazy.Internal (Text(..), chunk, empty, foldrChunks) +import Data.Text.Internal.Lazy (Text(..), chunk, empty, foldrChunks) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Internal as B import qualified Data.ByteString.Unsafe as B +#if MIN_VERSION_bytestring(0,10,4) +import Data.Word (Word8) +import Data.Monoid (mempty, (<>)) +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Extra as B (safeStrategy, toLazyByteStringWith) +import qualified Data.ByteString.Builder.Prim as BP +import qualified Data.Text as T +#endif import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.Encoding.Fusion as E -import qualified Data.Text.Lazy.Fusion as F +import qualified Data.Text.Internal.Lazy.Encoding.Fusion as E +import qualified Data.Text.Internal.Lazy.Fusion as F import Data.Text.Unsafe (unsafeDupablePerformIO) -- $strict @@ -136,8 +149,31 @@ {-# INLINE decodeUtf8' #-} encodeUtf8 :: Text -> B.ByteString +#if MIN_VERSION_bytestring(0,10,4) +encodeUtf8 Empty = B.empty +encodeUtf8 lt@(Chunk t _) = + B.toLazyByteStringWith strategy B.empty $ encodeUtf8Builder lt + where + -- To improve our small string performance, we use a strategy that + -- allocates a buffer that is guaranteed to be large enough for the + -- encoding of the first chunk, but not larger than the default + -- B.smallChunkSize. We clamp the firstChunkSize to ensure that we don't + -- generate too large buffers which hamper streaming. + firstChunkSize = min B.smallChunkSize (4 * (T.length t + 1)) + strategy = B.safeStrategy firstChunkSize B.defaultChunkSize + +encodeUtf8Builder :: Text -> B.Builder +encodeUtf8Builder = foldrChunks (\c b -> TE.encodeUtf8Builder c <> b) mempty + +{-# INLINE encodeUtf8BuilderEscaped #-} +encodeUtf8BuilderEscaped :: BP.BoundedPrim Word8 -> Text -> B.Builder +encodeUtf8BuilderEscaped prim = + foldrChunks (\c b -> TE.encodeUtf8BuilderEscaped prim c <> b) mempty + +#else encodeUtf8 (Chunk c cs) = B.Chunk (TE.encodeUtf8 c) (encodeUtf8 cs) encodeUtf8 Empty = B.Empty +#endif -- | Decode text from little endian UTF-16 encoding. decodeUtf16LEWith :: OnDecodeError -> B.ByteString -> Text diff --git a/Data/Text/Lazy/Encoding/Fusion.hs b/Data/Text/Lazy/Encoding/Fusion.hs deleted file mode 100644 --- a/Data/Text/Lazy/Encoding/Fusion.hs +++ /dev/null @@ -1,321 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, Rank2Types #-} - --- | --- Module : Data.Text.Lazy.Encoding.Fusion --- Copyright : (c) 2009, 2010 Bryan O'Sullivan --- --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org --- Stability : experimental --- Portability : portable --- --- Fusible 'Stream'-oriented functions for converting between lazy --- 'Text' and several common encodings. - -module Data.Text.Lazy.Encoding.Fusion - ( - -- * Streaming - -- streamASCII - streamUtf8 - , streamUtf16LE - , streamUtf16BE - , streamUtf32LE - , streamUtf32BE - - -- * Unstreaming - , unstream - - , module Data.Text.Encoding.Fusion.Common - ) where - -import Data.ByteString.Lazy.Internal (ByteString(..), defaultChunkSize) -import qualified Data.ByteString as B -import qualified Data.ByteString.Unsafe as B -import Data.Text.Encoding.Fusion.Common -import Data.Text.Encoding.Error -import Data.Text.Fusion (Step(..), Stream(..)) -import Data.Text.Fusion.Size -import Data.Text.UnsafeChar (unsafeChr, unsafeChr8, unsafeChr32) -import Data.Text.UnsafeShift (shiftL) -import Data.Word (Word8, Word16, Word32) -import qualified Data.Text.Encoding.Utf8 as U8 -import qualified Data.Text.Encoding.Utf16 as U16 -import qualified Data.Text.Encoding.Utf32 as U32 -import Data.Text.Unsafe (unsafeDupablePerformIO) -import Foreign.ForeignPtr (withForeignPtr, ForeignPtr) -import Foreign.Storable (pokeByteOff) -import Data.ByteString.Internal (mallocByteString, memcpy) -#if defined(ASSERTS) -import Control.Exception (assert) -#endif -import qualified Data.ByteString.Internal as B - -data S = S0 - | S1 {-# UNPACK #-} !Word8 - | S2 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 - | S3 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 - | S4 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 - -data T = T !ByteString !S {-# UNPACK #-} !Int - --- | /O(n)/ Convert a lazy 'ByteString' into a 'Stream Char', using --- UTF-8 encoding. -streamUtf8 :: OnDecodeError -> ByteString -> Stream Char -streamUtf8 onErr bs0 = Stream next (T bs0 S0 0) unknownSize - where - next (T bs@(Chunk ps _) S0 i) - | i < len && U8.validate1 a = - Yield (unsafeChr8 a) (T bs S0 (i+1)) - | i + 1 < len && U8.validate2 a b = - Yield (U8.chr2 a b) (T bs S0 (i+2)) - | i + 2 < len && U8.validate3 a b c = - Yield (U8.chr3 a b c) (T bs S0 (i+3)) - | i + 3 < len && U8.validate4 a b c d = - Yield (U8.chr4 a b c d) (T bs S0 (i+4)) - where len = B.length ps - a = B.unsafeIndex ps i - b = B.unsafeIndex ps (i+1) - c = B.unsafeIndex ps (i+2) - d = B.unsafeIndex ps (i+3) - next st@(T bs s i) = - case s of - S1 a | U8.validate1 a -> Yield (unsafeChr8 a) es - S2 a b | U8.validate2 a b -> Yield (U8.chr2 a b) es - S3 a b c | U8.validate3 a b c -> Yield (U8.chr3 a b c) es - S4 a b c d | U8.validate4 a b c d -> Yield (U8.chr4 a b c d) es - _ -> consume st - where es = T bs S0 i - consume (T bs@(Chunk ps rest) s i) - | i >= B.length ps = consume (T rest s 0) - | otherwise = - case s of - S0 -> next (T bs (S1 x) (i+1)) - S1 a -> next (T bs (S2 a x) (i+1)) - S2 a b -> next (T bs (S3 a b x) (i+1)) - S3 a b c -> next (T bs (S4 a b c x) (i+1)) - S4 a b c d -> decodeError "streamUtf8" "UTF-8" onErr (Just a) - (T bs (S3 b c d) (i+1)) - where x = B.unsafeIndex ps i - consume (T Empty S0 _) = Done - consume st = decodeError "streamUtf8" "UTF-8" onErr Nothing st -{-# INLINE [0] streamUtf8 #-} - --- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little --- endian UTF-16 encoding. -streamUtf16LE :: OnDecodeError -> ByteString -> Stream Char -streamUtf16LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize - where - next (T bs@(Chunk ps _) S0 i) - | i + 1 < len && U16.validate1 x1 = - Yield (unsafeChr x1) (T bs S0 (i+2)) - | i + 3 < len && U16.validate2 x1 x2 = - Yield (U16.chr2 x1 x2) (T bs S0 (i+4)) - where len = B.length ps - x1 = c (idx i) (idx (i + 1)) - x2 = c (idx (i + 2)) (idx (i + 3)) - c w1 w2 = w1 + (w2 `shiftL` 8) - idx = fromIntegral . B.unsafeIndex ps :: Int -> Word16 - next st@(T bs s i) = - case s of - S2 w1 w2 | U16.validate1 (c w1 w2) -> - Yield (unsafeChr (c w1 w2)) es - S4 w1 w2 w3 w4 | U16.validate2 (c w1 w2) (c w3 w4) -> - Yield (U16.chr2 (c w1 w2) (c w3 w4)) es - _ -> consume st - where es = T bs S0 i - c :: Word8 -> Word8 -> Word16 - c w1 w2 = fromIntegral w1 + (fromIntegral w2 `shiftL` 8) - consume (T bs@(Chunk ps rest) s i) - | i >= B.length ps = consume (T rest s 0) - | otherwise = - case s of - S0 -> next (T bs (S1 x) (i+1)) - S1 w1 -> next (T bs (S2 w1 x) (i+1)) - S2 w1 w2 -> next (T bs (S3 w1 w2 x) (i+1)) - S3 w1 w2 w3 -> next (T bs (S4 w1 w2 w3 x) (i+1)) - S4 w1 w2 w3 w4 -> decodeError "streamUtf16LE" "UTF-16LE" onErr (Just w1) - (T bs (S3 w2 w3 w4) (i+1)) - where x = B.unsafeIndex ps i - consume (T Empty S0 _) = Done - consume st = decodeError "streamUtf16LE" "UTF-16LE" onErr Nothing st -{-# INLINE [0] streamUtf16LE #-} - --- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big --- endian UTF-16 encoding. -streamUtf16BE :: OnDecodeError -> ByteString -> Stream Char -streamUtf16BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize - where - next (T bs@(Chunk ps _) S0 i) - | i + 1 < len && U16.validate1 x1 = - Yield (unsafeChr x1) (T bs S0 (i+2)) - | i + 3 < len && U16.validate2 x1 x2 = - Yield (U16.chr2 x1 x2) (T bs S0 (i+4)) - where len = B.length ps - x1 = c (idx i) (idx (i + 1)) - x2 = c (idx (i + 2)) (idx (i + 3)) - c w1 w2 = (w1 `shiftL` 8) + w2 - idx = fromIntegral . B.unsafeIndex ps :: Int -> Word16 - next st@(T bs s i) = - case s of - S2 w1 w2 | U16.validate1 (c w1 w2) -> - Yield (unsafeChr (c w1 w2)) es - S4 w1 w2 w3 w4 | U16.validate2 (c w1 w2) (c w3 w4) -> - Yield (U16.chr2 (c w1 w2) (c w3 w4)) es - _ -> consume st - where es = T bs S0 i - c :: Word8 -> Word8 -> Word16 - c w1 w2 = (fromIntegral w1 `shiftL` 8) + fromIntegral w2 - consume (T bs@(Chunk ps rest) s i) - | i >= B.length ps = consume (T rest s 0) - | otherwise = - case s of - S0 -> next (T bs (S1 x) (i+1)) - S1 w1 -> next (T bs (S2 w1 x) (i+1)) - S2 w1 w2 -> next (T bs (S3 w1 w2 x) (i+1)) - S3 w1 w2 w3 -> next (T bs (S4 w1 w2 w3 x) (i+1)) - S4 w1 w2 w3 w4 -> decodeError "streamUtf16BE" "UTF-16BE" onErr (Just w1) - (T bs (S3 w2 w3 w4) (i+1)) - where x = B.unsafeIndex ps i - consume (T Empty S0 _) = Done - consume st = decodeError "streamUtf16BE" "UTF-16BE" onErr Nothing st -{-# INLINE [0] streamUtf16BE #-} - --- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big --- endian UTF-32 encoding. -streamUtf32BE :: OnDecodeError -> ByteString -> Stream Char -streamUtf32BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize - where - next (T bs@(Chunk ps _) S0 i) - | i + 3 < len && U32.validate x = - Yield (unsafeChr32 x) (T bs S0 (i+4)) - where len = B.length ps - x = shiftL x1 24 + shiftL x2 16 + shiftL x3 8 + x4 - x1 = idx i - x2 = idx (i+1) - x3 = idx (i+2) - x4 = idx (i+3) - idx = fromIntegral . B.unsafeIndex ps :: Int -> Word32 - next st@(T bs s i) = - case s of - S4 w1 w2 w3 w4 | U32.validate (c w1 w2 w3 w4) -> - Yield (unsafeChr32 (c w1 w2 w3 w4)) es - _ -> consume st - where es = T bs S0 i - c :: Word8 -> Word8 -> Word8 -> Word8 -> Word32 - c w1 w2 w3 w4 = shifted - where - shifted = shiftL x1 24 + shiftL x2 16 + shiftL x3 8 + x4 - x1 = fromIntegral w1 - x2 = fromIntegral w2 - x3 = fromIntegral w3 - x4 = fromIntegral w4 - consume (T bs@(Chunk ps rest) s i) - | i >= B.length ps = consume (T rest s 0) - | otherwise = - case s of - S0 -> next (T bs (S1 x) (i+1)) - S1 w1 -> next (T bs (S2 w1 x) (i+1)) - S2 w1 w2 -> next (T bs (S3 w1 w2 x) (i+1)) - S3 w1 w2 w3 -> next (T bs (S4 w1 w2 w3 x) (i+1)) - S4 w1 w2 w3 w4 -> decodeError "streamUtf32BE" "UTF-32BE" onErr (Just w1) - (T bs (S3 w2 w3 w4) (i+1)) - where x = B.unsafeIndex ps i - consume (T Empty S0 _) = Done - consume st = decodeError "streamUtf32BE" "UTF-32BE" onErr Nothing st -{-# INLINE [0] streamUtf32BE #-} - --- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little --- endian UTF-32 encoding. -streamUtf32LE :: OnDecodeError -> ByteString -> Stream Char -streamUtf32LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize - where - next (T bs@(Chunk ps _) S0 i) - | i + 3 < len && U32.validate x = - Yield (unsafeChr32 x) (T bs S0 (i+4)) - where len = B.length ps - x = shiftL x4 24 + shiftL x3 16 + shiftL x2 8 + x1 - x1 = idx i - x2 = idx (i+1) - x3 = idx (i+2) - x4 = idx (i+3) - idx = fromIntegral . B.unsafeIndex ps :: Int -> Word32 - next st@(T bs s i) = - case s of - S4 w1 w2 w3 w4 | U32.validate (c w1 w2 w3 w4) -> - Yield (unsafeChr32 (c w1 w2 w3 w4)) es - _ -> consume st - where es = T bs S0 i - c :: Word8 -> Word8 -> Word8 -> Word8 -> Word32 - c w1 w2 w3 w4 = shifted - where - shifted = shiftL x4 24 + shiftL x3 16 + shiftL x2 8 + x1 - x1 = fromIntegral w1 - x2 = fromIntegral w2 - x3 = fromIntegral w3 - x4 = fromIntegral w4 - consume (T bs@(Chunk ps rest) s i) - | i >= B.length ps = consume (T rest s 0) - | otherwise = - case s of - S0 -> next (T bs (S1 x) (i+1)) - S1 w1 -> next (T bs (S2 w1 x) (i+1)) - S2 w1 w2 -> next (T bs (S3 w1 w2 x) (i+1)) - S3 w1 w2 w3 -> next (T bs (S4 w1 w2 w3 x) (i+1)) - S4 w1 w2 w3 w4 -> decodeError "streamUtf32LE" "UTF-32LE" onErr (Just w1) - (T bs (S3 w2 w3 w4) (i+1)) - where x = B.unsafeIndex ps i - consume (T Empty S0 _) = Done - consume st = decodeError "streamUtf32LE" "UTF-32LE" onErr Nothing st -{-# INLINE [0] streamUtf32LE #-} - --- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'. -unstreamChunks :: Int -> Stream Word8 -> ByteString -unstreamChunks chunkSize (Stream next s0 len0) = chunk s0 (upperBound 4 len0) - where chunk s1 len1 = unsafeDupablePerformIO $ do - let len = max 4 (min len1 chunkSize) - mallocByteString len >>= loop len 0 s1 - where - loop !n !off !s fp = case next s of - Done | off == 0 -> return Empty - | otherwise -> return $! Chunk (trimUp fp off) Empty - Skip s' -> loop n off s' fp - Yield x s' - | off == chunkSize -> do - let !newLen = n - off - return $! Chunk (trimUp fp off) (chunk s newLen) - | off == n -> realloc fp n off s' x - | otherwise -> do - withForeignPtr fp $ \p -> pokeByteOff p off x - loop n (off+1) s' fp - {-# NOINLINE realloc #-} - realloc fp n off s x = do - let n' = min (n+n) chunkSize - fp' <- copy0 fp n n' - withForeignPtr fp' $ \p -> pokeByteOff p off x - loop n' (off+1) s fp' - trimUp fp off = B.PS fp 0 off - copy0 :: ForeignPtr Word8 -> Int -> Int -> IO (ForeignPtr Word8) - copy0 !src !srcLen !destLen = -#if defined(ASSERTS) - assert (srcLen <= destLen) $ -#endif - do - dest <- mallocByteString destLen - withForeignPtr src $ \src' -> - withForeignPtr dest $ \dest' -> - memcpy dest' src' (fromIntegral srcLen) - return dest - --- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'. -unstream :: Stream Word8 -> ByteString -unstream = unstreamChunks defaultChunkSize - -decodeError :: forall s. String -> String -> OnDecodeError -> Maybe Word8 - -> s -> Step s Char -decodeError func kind onErr mb i = - case onErr desc mb of - Nothing -> Skip i - Just c -> Yield c i - where desc = "Data.Text.Lazy.Encoding.Fusion." ++ func ++ ": Invalid " ++ - kind ++ " stream" diff --git a/Data/Text/Lazy/Fusion.hs b/Data/Text/Lazy/Fusion.hs deleted file mode 100644 --- a/Data/Text/Lazy/Fusion.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE BangPatterns #-} --- | --- Module : Data.Text.Lazy.Fusion --- Copyright : (c) 2009, 2010 Bryan O'Sullivan --- --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org --- Stability : experimental --- Portability : GHC --- --- Core stream fusion functionality for text. - -module Data.Text.Lazy.Fusion - ( - stream - , unstream - , unstreamChunks - , length - , unfoldrN - , index - , countChar - ) where - -import Prelude hiding (length) -import qualified Data.Text.Fusion.Common as S -import Control.Monad.ST (runST) -import Data.Text.Fusion.Internal -import Data.Text.Fusion.Size (isEmpty, unknownSize) -import Data.Text.Lazy.Internal -import qualified Data.Text.Internal as I -import qualified Data.Text.Array as A -import Data.Text.UnsafeChar (unsafeWrite) -import Data.Text.UnsafeShift (shiftL) -import Data.Text.Unsafe (Iter(..), iter) -import Data.Int (Int64) - -default(Int64) - --- | /O(n)/ Convert a 'Text' into a 'Stream Char'. -stream :: Text -> Stream Char -stream text = Stream next (text :*: 0) unknownSize - where - next (Empty :*: _) = Done - next (txt@(Chunk t@(I.Text _ _ len) ts) :*: i) - | i >= len = next (ts :*: 0) - | otherwise = Yield c (txt :*: i+d) - where Iter c d = iter t i -{-# INLINE [0] stream #-} - --- | /O(n)/ Convert a 'Stream Char' into a 'Text', using the given --- chunk size. -unstreamChunks :: Int -> Stream Char -> Text -unstreamChunks !chunkSize (Stream next s0 len0) - | isEmpty len0 = Empty - | otherwise = outer s0 - where - outer so = {-# SCC "unstreamChunks/outer" #-} - case next so of - Done -> Empty - Skip s' -> outer s' - Yield x s' -> runST $ do - a <- A.new unknownLength - unsafeWrite a 0 x >>= inner a unknownLength s' - where unknownLength = 4 - where - inner marr !len s !i - | i + 1 >= chunkSize = finish marr i s - | i + 1 >= len = {-# SCC "unstreamChunks/resize" #-} do - let newLen = min (len `shiftL` 1) chunkSize - marr' <- A.new newLen - A.copyM marr' 0 marr 0 len - inner marr' newLen s i - | otherwise = - {-# SCC "unstreamChunks/inner" #-} - case next s of - Done -> finish marr i s - Skip s' -> inner marr len s' i - Yield x s' -> do d <- unsafeWrite marr i x - inner marr len s' (i+d) - finish marr len s' = do - arr <- A.unsafeFreeze marr - return (I.Text arr 0 len `Chunk` outer s') -{-# INLINE [0] unstreamChunks #-} - --- | /O(n)/ Convert a 'Stream Char' into a 'Text', using --- 'defaultChunkSize'. -unstream :: Stream Char -> Text -unstream = unstreamChunks defaultChunkSize -{-# INLINE [0] unstream #-} - --- | /O(n)/ Returns the number of characters in a text. -length :: Stream Char -> Int64 -length = S.lengthI -{-# INLINE[0] length #-} - -{-# RULES "LAZY STREAM stream/unstream fusion" forall s. - stream (unstream s) = s #-} - --- | /O(n)/ Like 'unfoldr', '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 :: Int64 -> (a -> Maybe (Char,a)) -> a -> Stream Char -unfoldrN n = S.unfoldrNI n -{-# INLINE [0] unfoldrN #-} - --- | /O(n)/ stream index (subscript) operator, starting from 0. -index :: Stream Char -> Int64 -> Char -index = S.indexI -{-# INLINE [0] index #-} - --- | /O(n)/ The 'count' function returns the number of times the query --- element appears in the given stream. -countChar :: Char -> Stream Char -> Int64 -countChar = S.countCharI -{-# INLINE [0] countChar #-} diff --git a/Data/Text/Lazy/IO.hs b/Data/Text/Lazy/IO.hs --- a/Data/Text/Lazy/IO.hs +++ b/Data/Text/Lazy/IO.hs @@ -50,8 +50,8 @@ import qualified Control.Exception as E import Control.Monad (when) import Data.IORef (readIORef) -import Data.Text.IO.Internal (hGetLineWith, readChunk) -import Data.Text.Lazy.Internal (chunk, empty) +import Data.Text.Internal.IO (hGetLineWith, readChunk) +import Data.Text.Internal.Lazy (chunk, empty) import GHC.IO.Buffer (isEmptyBuffer) import GHC.IO.Exception (IOException(..), IOErrorType(..), ioException) import GHC.IO.Handle.Internals (augmentIOError, hClose_help, diff --git a/Data/Text/Lazy/Internal.hs b/Data/Text/Lazy/Internal.hs --- a/Data/Text/Lazy/Internal.hs +++ b/Data/Text/Lazy/Internal.hs @@ -1,118 +1,20 @@ {-# LANGUAGE BangPatterns, DeriveDataTypeable #-} -- | -- Module : Data.Text.Lazy.Internal --- Copyright : (c) 2009, 2010 Bryan O'Sullivan +-- Copyright : (c) 2013 Bryan O'Sullivan -- -- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org +-- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- --- A module containing private 'Text' internals. This exposes the --- 'Text' representation and low level construction functions. --- Modules which extend the 'Text' system may need to use this module. --- --- You should not use this module unless you are determined to monkey --- with the internals, as the functions here do just about nothing to --- preserve data invariants. You have been warned! +-- This module has been renamed to 'Data.Text.Internal.Lazy'. This +-- name for the module will be removed in the next major release. module Data.Text.Lazy.Internal + {-# DEPRECATED "Use Data.Text.Internal.Lazy instead" #-} ( - Text(..) - , chunk - , empty - , foldrChunks - , foldlChunks - -- * Data type invariant and abstraction functions - - -- $invariant - , strictInvariant - , lazyInvariant - , showStructure - - -- * Chunk allocation sizes - , defaultChunkSize - , smallChunkSize - , chunkOverhead + module Data.Text.Internal.Lazy ) where -import Data.Text () -import Data.Text.UnsafeShift (shiftL) -import Data.Typeable (Typeable) -import Foreign.Storable (sizeOf) -import qualified Data.Text.Internal as T - -data Text = Empty - | Chunk {-# UNPACK #-} !T.Text Text - deriving (Typeable) - --- $invariant --- --- The data type invariant for lazy 'Text': Every 'Text' is either 'Empty' or --- consists of non-null 'T.Text's. All functions must preserve this, --- and the QC properties must check this. - --- | Check the invariant strictly. -strictInvariant :: Text -> Bool -strictInvariant Empty = True -strictInvariant x@(Chunk (T.Text _ _ len) cs) - | len > 0 = strictInvariant cs - | otherwise = error $ "Data.Text.Lazy: invariant violation: " - ++ showStructure x - --- | Check the invariant lazily. -lazyInvariant :: Text -> Text -lazyInvariant Empty = Empty -lazyInvariant x@(Chunk c@(T.Text _ _ len) cs) - | len > 0 = Chunk c (lazyInvariant cs) - | otherwise = error $ "Data.Text.Lazy: invariant violation: " - ++ showStructure x - --- | Display the internal structure of a lazy 'Text'. -showStructure :: Text -> String -showStructure Empty = "Empty" -showStructure (Chunk t Empty) = "Chunk " ++ show t ++ " Empty" -showStructure (Chunk t ts) = - "Chunk " ++ show t ++ " (" ++ showStructure ts ++ ")" - --- | Smart constructor for 'Chunk'. Guarantees the data type invariant. -chunk :: T.Text -> Text -> Text -{-# INLINE chunk #-} -chunk t@(T.Text _ _ len) ts | len == 0 = ts - | otherwise = Chunk t ts - --- | Smart constructor for 'Empty'. -empty :: Text -{-# INLINE [0] empty #-} -empty = Empty - --- | Consume the chunks of a lazy 'Text' with a natural right fold. -foldrChunks :: (T.Text -> a -> a) -> a -> Text -> a -foldrChunks f z = go - where go Empty = z - go (Chunk c cs) = f c (go cs) -{-# INLINE foldrChunks #-} - --- | Consume the chunks of a lazy 'Text' with a strict, tail-recursive, --- accumulating left fold. -foldlChunks :: (a -> T.Text -> a) -> a -> Text -> a -foldlChunks f z = go z - where go !a Empty = a - go !a (Chunk c cs) = go (f a c) cs -{-# INLINE foldlChunks #-} - --- | Currently set to 16 KiB, less the memory management overhead. -defaultChunkSize :: Int -defaultChunkSize = 16384 - chunkOverhead -{-# INLINE defaultChunkSize #-} - --- | Currently set to 128 bytes, less the memory management overhead. -smallChunkSize :: Int -smallChunkSize = 128 - chunkOverhead -{-# INLINE smallChunkSize #-} - --- | The memory management overhead. Currently this is tuned for GHC only. -chunkOverhead :: Int -chunkOverhead = sizeOf (undefined :: Int) `shiftL` 1 -{-# INLINE chunkOverhead #-} +import Data.Text.Internal.Lazy diff --git a/Data/Text/Lazy/Search.hs b/Data/Text/Lazy/Search.hs deleted file mode 100644 --- a/Data/Text/Lazy/Search.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} - --- | --- Module : Data.Text.Lazy.Search --- Copyright : (c) 2009, 2010 Bryan O'Sullivan --- --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org --- Stability : experimental --- Portability : GHC --- --- Fast substring search for lazy 'Text', based on work by Boyer, --- Moore, Horspool, Sunday, and Lundh. Adapted from the strict --- implementation. - -module Data.Text.Lazy.Search - ( - indices - ) where - -import qualified Data.Text.Array as A -import Data.Int (Int64) -import Data.Word (Word16, Word64) -import qualified Data.Text.Internal as T -import Data.Text.Fusion.Internal (PairS(..)) -import Data.Text.Lazy.Internal (Text(..), foldlChunks) -import Data.Bits ((.|.), (.&.)) -import Data.Text.UnsafeShift (shiftL) - --- | /O(n+m)/ Find the offsets of all non-overlapping indices of --- @needle@ within @haystack@. --- --- This function is strict in @needle@, and lazy (as far as possible) --- in the chunks of @haystack@. --- --- In (unlikely) bad cases, this algorithm's complexity degrades --- towards /O(n*m)/. -indices :: Text -- ^ Substring to search for (@needle@) - -> Text -- ^ Text to search in (@haystack@) - -> [Int64] -indices needle@(Chunk n ns) _haystack@(Chunk k ks) - | nlen <= 0 = [] - | nlen == 1 = indicesOne (nindex 0) 0 k ks - | otherwise = advance k ks 0 0 - where - advance x@(T.Text _ _ l) xs = scan - where - scan !g !i - | i >= m = case xs of - Empty -> [] - Chunk y ys -> advance y ys g (i-m) - | lackingHay (i + nlen) x xs = [] - | c == z && candidateMatch 0 = g : scan (g+nlen) (i+nlen) - | otherwise = scan (g+delta) (i+delta) - where - m = fromIntegral l - c = hindex (i + nlast) - delta | nextInPattern = nlen + 1 - | c == z = skip + 1 - | otherwise = 1 - nextInPattern = mask .&. swizzle (hindex (i+nlen)) == 0 - candidateMatch !j - | j >= nlast = True - | hindex (i+j) /= nindex j = False - | otherwise = candidateMatch (j+1) - hindex = index x xs - nlen = wordLength needle - nlast = nlen - 1 - nindex = index n ns - z = foldlChunks fin 0 needle - where fin _ (T.Text farr foff flen) = A.unsafeIndex farr (foff+flen-1) - (mask :: Word64) :*: skip = buildTable n ns 0 0 0 (nlen-2) - swizzle w = 1 `shiftL` (fromIntegral w .&. 0x3f) - buildTable (T.Text xarr xoff xlen) xs = go - where - go !(g::Int64) !i !msk !skp - | i >= xlast = case xs of - Empty -> (msk .|. swizzle z) :*: skp - Chunk y ys -> buildTable y ys g 0 msk' skp' - | otherwise = go (g+1) (i+1) msk' skp' - where c = A.unsafeIndex xarr (xoff+i) - msk' = msk .|. swizzle c - skp' | c == z = nlen - g - 2 - | otherwise = skp - xlast = xlen - 1 - -- | Check whether an attempt to index into the haystack at the - -- given offset would fail. - lackingHay q = go 0 - where - go p (T.Text _ _ l) ps = p' < q && case ps of - Empty -> True - Chunk r rs -> go p' r rs - where p' = p + fromIntegral l -indices _ _ = [] - --- | Fast index into a partly unpacked 'Text'. We take into account --- the possibility that the caller might try to access one element --- past the end. -index :: T.Text -> Text -> Int64 -> Word16 -index (T.Text arr off len) xs !i - | j < len = A.unsafeIndex arr (off+j) - | otherwise = case xs of - Empty - -- out of bounds, but legal - | j == len -> 0 - -- should never happen, due to lackingHay above - | otherwise -> emptyError "index" - Chunk c cs -> index c cs (i-fromIntegral len) - where j = fromIntegral i - --- | A variant of 'indices' that scans linearly for a single 'Word16'. -indicesOne :: Word16 -> Int64 -> T.Text -> Text -> [Int64] -indicesOne c = chunk - where - chunk !i (T.Text oarr ooff olen) os = go 0 - where - go h | h >= olen = case os of - Empty -> [] - Chunk y ys -> chunk (i+fromIntegral olen) y ys - | on == c = i + fromIntegral h : go (h+1) - | otherwise = go (h+1) - where on = A.unsafeIndex oarr (ooff+h) - --- | The number of 'Word16' values in a 'Text'. -wordLength :: Text -> Int64 -wordLength = foldlChunks sumLength 0 - where sumLength i (T.Text _ _ l) = i + fromIntegral l - -emptyError :: String -> a -emptyError fun = error ("Data.Text.Lazy.Search." ++ fun ++ ": empty input") diff --git a/Data/Text/Private.hs b/Data/Text/Private.hs deleted file mode 100644 --- a/Data/Text/Private.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-} - --- | --- Module : Data.Text.Private --- Copyright : (c) 2011 Bryan O'Sullivan --- --- License : BSD-style --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : GHC - -module Data.Text.Private - ( - runText - , span_ - ) where - -import Control.Monad.ST (ST, runST) -import Data.Text.Internal (Text(..), textP) -import Data.Text.Unsafe (Iter(..), iter) -import qualified Data.Text.Array as A - -span_ :: (Char -> Bool) -> Text -> (# Text, Text #) -span_ p t@(Text arr off len) = (# hd,tl #) - where hd = textP arr off k - tl = textP arr (off+k) (len-k) - !k = loop 0 - loop !i | i < len && p c = loop (i+d) - | otherwise = i - where Iter c d = iter t i -{-# INLINE span_ #-} - -runText :: (forall s. (A.MArray s -> Int -> ST s Text) -> ST s Text) -> Text -runText act = runST (act $ \ !marr !len -> do - arr <- A.unsafeFreeze marr - return $! textP arr 0 len) -{-# INLINE runText #-} diff --git a/Data/Text/Read.hs b/Data/Text/Read.hs --- a/Data/Text/Read.hs +++ b/Data/Text/Read.hs @@ -28,7 +28,7 @@ import Data.Int (Int8, Int16, Int32, Int64) import Data.Ratio ((%)) import Data.Text as T -import Data.Text.Private (span_) +import Data.Text.Internal.Private (span_) import Data.Word (Word, Word8, Word16, Word32, Word64) -- | Read some text. If the read succeeds, return its value and the diff --git a/Data/Text/Search.hs b/Data/Text/Search.hs deleted file mode 100644 --- a/Data/Text/Search.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} - --- | --- Module : Data.Text.Search --- Copyright : (c) Bryan O'Sullivan 2009 --- --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org --- Stability : experimental --- Portability : GHC --- --- Fast substring search for 'Text', based on work by Boyer, Moore, --- Horspool, Sunday, and Lundh. --- --- References: --- --- * R. S. Boyer, J. S. Moore: A Fast String Searching Algorithm. --- Communications of the ACM, 20, 10, 762-772 (1977) --- --- * R. N. Horspool: Practical Fast Searching in Strings. Software - --- Practice and Experience 10, 501-506 (1980) --- --- * D. M. Sunday: A Very Fast Substring Search Algorithm. --- Communications of the ACM, 33, 8, 132-142 (1990) --- --- * F. Lundh: The Fast Search Algorithm. --- (2006) - -module Data.Text.Search - ( - indices - ) where - -import qualified Data.Text.Array as A -import Data.Word (Word64) -import Data.Text.Internal (Text(..)) -import Data.Bits ((.|.), (.&.)) -import Data.Text.UnsafeShift (shiftL) - -data T = {-# UNPACK #-} !Word64 :* {-# UNPACK #-} !Int - --- | /O(n+m)/ Find the offsets of all non-overlapping indices of --- @needle@ within @haystack@. The offsets returned represent --- uncorrected indices in the low-level \"needle\" array, to which its --- offset must be added. --- --- In (unlikely) bad cases, this algorithm's complexity degrades --- towards /O(n*m)/. -indices :: Text -- ^ Substring to search for (@needle@) - -> Text -- ^ Text to search in (@haystack@) - -> [Int] -indices _needle@(Text narr noff nlen) _haystack@(Text harr hoff hlen) - | nlen == 1 = scanOne (nindex 0) - | nlen <= 0 || ldiff < 0 = [] - | otherwise = scan 0 - where - ldiff = hlen - nlen - nlast = nlen - 1 - z = nindex nlast - nindex k = A.unsafeIndex narr (noff+k) - hindex k = A.unsafeIndex harr (hoff+k) - hindex' k | k == hlen = 0 - | otherwise = A.unsafeIndex harr (hoff+k) - buildTable !i !msk !skp - | i >= nlast = (msk .|. swizzle z) :* skp - | otherwise = buildTable (i+1) (msk .|. swizzle c) skp' - where c = nindex i - skp' | c == z = nlen - i - 2 - | otherwise = skp - swizzle k = 1 `shiftL` (fromIntegral k .&. 0x3f) - scan !i - | i > ldiff = [] - | c == z && candidateMatch 0 = i : scan (i + nlen) - | otherwise = scan (i + delta) - where c = hindex (i + nlast) - candidateMatch !j - | j >= nlast = True - | hindex (i+j) /= nindex j = False - | otherwise = candidateMatch (j+1) - delta | nextInPattern = nlen + 1 - | c == z = skip + 1 - | otherwise = 1 - where nextInPattern = mask .&. swizzle (hindex' (i+nlen)) == 0 - !(mask :* skip) = buildTable 0 0 (nlen-2) - scanOne c = loop 0 - where loop !i | i >= hlen = [] - | hindex i == c = i : loop (i+1) - | otherwise = loop (i+1) -{-# INLINE indices #-} diff --git a/Data/Text/Unsafe.hs b/Data/Text/Unsafe.hs --- a/Data/Text/Unsafe.hs +++ b/Data/Text/Unsafe.hs @@ -3,8 +3,7 @@ -- Module : Data.Text.Unsafe -- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan -- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org +-- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- @@ -29,10 +28,10 @@ #if defined(ASSERTS) import Control.Exception (assert) #endif -import Data.Text.Encoding.Utf16 (chr2) +import Data.Text.Internal.Encoding.Utf16 (chr2) import Data.Text.Internal (Text(..)) -import Data.Text.Unsafe.Base (inlineInterleaveST, inlinePerformIO) -import Data.Text.UnsafeChar (unsafeChr) +import Data.Text.Internal.Unsafe (inlineInterleaveST, inlinePerformIO) +import Data.Text.Internal.Unsafe.Char (unsafeChr) import qualified Data.Text.Array as A import GHC.IO (unsafeDupablePerformIO) diff --git a/Data/Text/Unsafe/Base.hs b/Data/Text/Unsafe/Base.hs deleted file mode 100644 --- a/Data/Text/Unsafe/Base.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} --- | --- Module : Data.Text.Unsafe.Base --- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org --- Stability : experimental --- Portability : portable --- --- A module containing unsafe operations, for very very careful use in --- heavily tested code. -module Data.Text.Unsafe.Base - ( - inlineInterleaveST - , inlinePerformIO - ) where - -import GHC.ST (ST(..)) -#if defined(__GLASGOW_HASKELL__) -import GHC.IO (IO(IO)) -import GHC.Base (realWorld#) -#endif - - --- | Just like unsafePerformIO, but we inline it. Big performance gains as --- it exposes lots of things to further inlining. /Very unsafe/. In --- particular, you should do no memory allocation inside an --- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@. --- -{-# INLINE inlinePerformIO #-} -inlinePerformIO :: IO a -> a -#if defined(__GLASGOW_HASKELL__) -inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r -#else -inlinePerformIO = unsafePerformIO -#endif - --- | Allow an 'ST' computation to be deferred lazily. When passed an --- action of type 'ST' @s@ @a@, the action will only be performed when --- the value of @a@ is demanded. --- --- This function is identical to the normal unsafeInterleaveST, but is --- inlined and hence faster. --- --- /Note/: This operation is highly unsafe, as it can introduce --- externally visible non-determinism into an 'ST' action. -inlineInterleaveST :: ST s a -> ST s a -inlineInterleaveST (ST m) = ST $ \ s -> - let r = case m s of (# _, res #) -> res in (# s, r #) -{-# INLINE inlineInterleaveST #-} diff --git a/Data/Text/UnsafeChar.hs b/Data/Text/UnsafeChar.hs deleted file mode 100644 --- a/Data/Text/UnsafeChar.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE CPP, MagicHash #-} - --- | --- Module : Data.Text.UnsafeChar --- Copyright : (c) 2008, 2009 Tom Harper, --- (c) 2009, 2010 Bryan O'Sullivan, --- (c) 2009 Duncan Coutts --- --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org --- Stability : experimental --- Portability : GHC --- --- Fast character manipulation functions. -module Data.Text.UnsafeChar - ( - ord - , unsafeChr - , unsafeChr8 - , unsafeChr32 - , unsafeWrite - -- , unsafeWriteRev - ) where - -#ifdef ASSERTS -import Control.Exception (assert) -#endif -import Control.Monad.ST (ST) -import Data.Bits ((.&.)) -import Data.Text.UnsafeShift (shiftR) -import GHC.Exts (Char(..), Int(..), chr#, ord#, word2Int#) -import GHC.Word (Word8(..), Word16(..), Word32(..)) -import qualified Data.Text.Array as A - -ord :: Char -> Int -ord (C# c#) = I# (ord# c#) -{-# INLINE ord #-} - -unsafeChr :: Word16 -> Char -unsafeChr (W16# w#) = C# (chr# (word2Int# w#)) -{-# INLINE unsafeChr #-} - -unsafeChr8 :: Word8 -> Char -unsafeChr8 (W8# w#) = C# (chr# (word2Int# w#)) -{-# INLINE unsafeChr8 #-} - -unsafeChr32 :: Word32 -> Char -unsafeChr32 (W32# w#) = C# (chr# (word2Int# w#)) -{-# INLINE unsafeChr32 #-} - --- | Write a character into the array at the given offset. Returns --- the number of 'Word16's written. -unsafeWrite :: A.MArray s -> Int -> Char -> ST s Int -unsafeWrite marr i c - | n < 0x10000 = do -#if defined(ASSERTS) - assert (i >= 0) . assert (i < A.length marr) $ return () -#endif - A.unsafeWrite marr i (fromIntegral n) - return 1 - | otherwise = do -#if defined(ASSERTS) - assert (i >= 0) . assert (i < A.length marr - 1) $ return () -#endif - A.unsafeWrite marr i lo - A.unsafeWrite marr (i+1) hi - return 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/Data/Text/UnsafeShift.hs b/Data/Text/UnsafeShift.hs deleted file mode 100644 --- a/Data/Text/UnsafeShift.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE MagicHash #-} - --- | --- Module : Data.Text.UnsafeShift --- Copyright : (c) Bryan O'Sullivan 2009 --- --- License : BSD-style --- Maintainer : bos@serpentine.com, rtomharper@googlemail.com, --- duncan@haskell.org --- Stability : experimental --- Portability : GHC --- --- Fast, unchecked bit shifting functions. - -module Data.Text.UnsafeShift - ( - UnsafeShift(..) - ) where - --- import qualified Data.Bits as Bits -import GHC.Base -import GHC.Word - --- | This is a workaround for poor optimisation in GHC 6.8.2. It --- fails to notice constant-width shifts, and adds a test and branch --- to every shift. This imposes about a 10% performance hit. --- --- These functions are undefined when the amount being shifted by is --- greater than the size in bits of a machine Int#. -class UnsafeShift a where - shiftL :: a -> Int -> a - shiftR :: a -> Int -> a - -instance UnsafeShift Word16 where - {-# INLINE shiftL #-} - shiftL (W16# x#) (I# i#) = W16# (narrow16Word# (x# `uncheckedShiftL#` i#)) - - {-# INLINE shiftR #-} - shiftR (W16# x#) (I# i#) = W16# (x# `uncheckedShiftRL#` i#) - -instance UnsafeShift Word32 where - {-# INLINE shiftL #-} - shiftL (W32# x#) (I# i#) = W32# (narrow32Word# (x# `uncheckedShiftL#` i#)) - - {-# INLINE shiftR #-} - shiftR (W32# x#) (I# i#) = W32# (x# `uncheckedShiftRL#` i#) - -instance UnsafeShift Word64 where - {-# INLINE shiftL #-} - shiftL (W64# x#) (I# i#) = W64# (x# `uncheckedShiftL64#` i#) - - {-# INLINE shiftR #-} - shiftR (W64# x#) (I# i#) = W64# (x# `uncheckedShiftRL64#` i#) - -instance UnsafeShift Int where - {-# INLINE shiftL #-} - shiftL (I# x#) (I# i#) = I# (x# `iShiftL#` i#) - - {-# INLINE shiftR #-} - shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#) - -{- -instance UnsafeShift Integer where - {-# INLINE shiftL #-} - shiftL = Bits.shiftL - - {-# INLINE shiftR #-} - shiftR = Bits.shiftR --} diff --git a/Data/Text/Util.hs b/Data/Text/Util.hs deleted file mode 100644 --- a/Data/Text/Util.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable #-} - --- | --- Module : Data.Text.Util --- Copyright : 2010 Bryan O'Sullivan --- --- License : BSD-style --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : GHC --- --- Useful functions. - -module Data.Text.Util - ( - intersperse - ) where - --- | A lazier version of Data.List.intersperse. The other version --- causes space leaks! -intersperse :: a -> [a] -> [a] -intersperse _ [] = [] -intersperse sep (x:xs) = x : go xs - where - go [] = [] - go (y:ys) = sep : y: go ys -{-# INLINE intersperse #-} diff --git a/benchmarks/haskell/Benchmarks.hs b/benchmarks/haskell/Benchmarks.hs --- a/benchmarks/haskell/Benchmarks.hs +++ b/benchmarks/haskell/Benchmarks.hs @@ -49,7 +49,10 @@ , Equality.benchmark (tf "japanese.txt") , FileRead.benchmark (tf "russian.txt") , FoldLines.benchmark (tf "russian.txt") - , Pure.benchmark "tiny "(tf "tiny.txt") + , Pure.benchmark "tiny" (tf "tiny.txt") + , Pure.benchmark "ascii" (tf "ascii-small.txt") + , Pure.benchmark "france" (tf "france.html") + , Pure.benchmark "russian" (tf "russian-small.txt") , Pure.benchmark "japanese" (tf "japanese.txt") , ReadNumbers.benchmark (tf "numbers.txt") , Replace.benchmark (tf "russian.txt") "принимая" "своем" diff --git a/benchmarks/haskell/Benchmarks/Stream.hs b/benchmarks/haskell/Benchmarks/Stream.hs --- a/benchmarks/haskell/Benchmarks/Stream.hs +++ b/benchmarks/haskell/Benchmarks/Stream.hs @@ -13,16 +13,16 @@ import Control.DeepSeq (NFData (..)) import Criterion (Benchmark, bgroup, bench, nf) -import Data.Text.Fusion.Internal (Step (..), Stream (..)) +import Data.Text.Internal.Fusion.Types (Step (..), Stream (..)) import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as E -import qualified Data.Text.Encoding.Fusion as T -import qualified Data.Text.Encoding.Fusion.Common as F -import qualified Data.Text.Fusion as T +import qualified Data.Text.Internal.Encoding.Fusion as T +import qualified Data.Text.Internal.Encoding.Fusion.Common as F +import qualified Data.Text.Internal.Fusion as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Text.Lazy.Encoding.Fusion as TL -import qualified Data.Text.Lazy.Fusion as TL +import qualified Data.Text.Internal.Lazy.Encoding.Fusion as TL +import qualified Data.Text.Internal.Lazy.Fusion as TL import qualified Data.Text.Lazy.IO as TL instance NFData a => NFData (Stream a) where diff --git a/cbits/cbits.c b/cbits/cbits.c --- a/cbits/cbits.c +++ b/cbits/cbits.c @@ -229,3 +229,70 @@ ret -= 1; return ret; } + +void +_hs_text_encode_utf8(uint8_t **destp, const uint16_t *src, size_t srcoff, + size_t srclen) +{ + const uint16_t *srcend; + uint8_t *dest = *destp; + + src += srcoff; + srcend = src + srclen; + + ascii: +#if defined(__x86_64__) + while (srcend - src >= 4) { + uint64_t w = *((uint64_t *) src); + + if (w & 0xFF80FF80FF80FF80ULL) + break; + *dest++ = w & 0xFFFF; + *dest++ = (w >> 16) & 0xFFFF; + *dest++ = (w >> 32) & 0xFFFF; + *dest++ = w >> 48; + src += 4; + } +#endif + +#if defined(__i386__) + while (srcend - src >= 2) { + uint32_t w = *((uint32_t *) src); + + if (w & 0xFF80FF80) + break; + *dest++ = w & 0xFFFF; + *dest++ = w >> 16; + src += 2; + } +#endif + + while (src < srcend) { + uint16_t w = *src++; + + if (w <= 0x7F) { + *dest++ = w; + /* An ASCII byte is likely to begin a run of ASCII bytes. + Falling back into the fast path really helps performance. */ + goto ascii; + } + else if (w <= 0x7FF) { + *dest++ = (w >> 6) | 0xC0; + *dest++ = (w & 0x3f) | 0x80; + } + else if (w < 0xD800 || w > 0xDBFF) { + *dest++ = (w >> 12) | 0xE0; + *dest++ = ((w >> 6) & 0x3F) | 0x80; + *dest++ = (w & 0x3F) | 0x80; + } else { + uint32_t c = ((((uint32_t) w) - 0xD800) << 10) + + (((uint32_t) *src++) - 0xDC00) + 0x10000; + *dest++ = (c >> 18) | 0xF0; + *dest++ = ((c >> 12) & 0x3F) | 0x80; + *dest++ = ((c >> 6) & 0x3F) | 0x80; + *dest++ = (c & 0x3F) | 0x80; + } + } + + *destp = dest; +} diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,23 @@ +1.1.0.0 + + * encodeUtf8: Performance is improved by up to 4x. + + * encodeUtf8Builder, encodeUtf8BuilderEscaped: new functions, + available only if bytestring >= 0.10.4.0 is installed, that + allow very fast and flexible encoding of a Text value to a + bytestring Builder. + + As an example of the performance gain to be had, the + encodeUtf8BuilderEscaped function helps to double the speed + of JSON encoding in the latest version of aeson! (Note: if + all you need is a plain ByteString, encodeUtf8 is still the + faster way to go.) + + * All of the internal module hierarchy is now publicly + exposed. If a module is in the .Internal hierarchy, or is + documented as internal, use at your own risk - there are no + API stability guarantees for internal modules! + 1.0.0.1 * decodeUtf8: Fixed a regression that caused us to incorrectly diff --git a/scripts/CaseMapping.hs b/scripts/CaseMapping.hs --- a/scripts/CaseMapping.hs +++ b/scripts/CaseMapping.hs @@ -29,7 +29,7 @@ ["" ,"module Data.Text.Fusion.CaseMapping where" ,"import Data.Char" - ,"import Data.Text.Fusion.Internal" + ,"import Data.Text.Internal.Fusion.Types" ,""] mapM_ (hPutStrLn h) (mapSC "upper" upper toUpper scs) mapM_ (hPutStrLn h) (mapSC "lower" lower toLower scs) diff --git a/tests/Tests/Properties.hs b/tests/Tests/Properties.hs --- a/tests/Tests/Properties.hs +++ b/tests/Tests/Properties.hs @@ -22,12 +22,12 @@ import Data.Monoid (Monoid(..)) import Data.String (fromString) import Data.Text.Encoding.Error -import Data.Text.Encoding.Utf8 import Data.Text.Foreign -import Data.Text.Fusion.Size +import Data.Text.Internal.Encoding.Utf8 +import Data.Text.Internal.Fusion.Size import Data.Text.Lazy.Read as TL import Data.Text.Read as T -import Data.Text.Search (indices) +import Data.Text.Internal.Search (indices) import Data.Word (Word, Word8, Word16, Word32, Word64) import Numeric (showHex) import Test.Framework (Test, testGroup) @@ -38,18 +38,18 @@ import qualified Data.List as L import qualified Data.Text as T import qualified Data.Text.Encoding as E -import qualified Data.Text.Fusion as S -import qualified Data.Text.Fusion.Common as S +import qualified Data.Text.Internal.Fusion as S +import qualified Data.Text.Internal.Fusion.Common as S import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB import qualified Data.Text.Lazy.Builder.Int as TB import qualified Data.Text.Lazy.Builder.RealFloat as TB import qualified Data.Text.Lazy.Encoding as EL -import qualified Data.Text.Lazy.Fusion as SL +import qualified Data.Text.Internal.Lazy.Fusion as SL import qualified Data.Text.Lazy.IO as TL -import qualified Data.Text.Lazy.Search as S (indices) -import qualified Data.Text.UnsafeShift as U +import qualified Data.Text.Internal.Lazy.Search as S (indices) +import qualified Data.Text.Internal.Unsafe.Shift as U import qualified System.IO as IO import Tests.QuickCheckUtils @@ -148,7 +148,7 @@ -- invalid leading byte of a 4-byte sequence , (:) <$> choose (0xF5, 0xFF) <*> upTo 3 contByte -- 4-byte sequence greater than U+10FFFF - , do k <- choose (0x11, 0x1F) + , do k <- choose (0x11, 0x13) let w0 = 0xF0 + (k `Bits.shiftR` 2) w1 = 0x80 + ((k .&. 3) `Bits.shiftL` 4) ([w0,w1]++) <$> vectorOf 2 contByte diff --git a/tests/Tests/QuickCheckUtils.hs b/tests/Tests/QuickCheckUtils.hs --- a/tests/Tests/QuickCheckUtils.hs +++ b/tests/Tests/QuickCheckUtils.hs @@ -44,11 +44,11 @@ import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.Encoding.Error as T -import qualified Data.Text.Fusion as TF -import qualified Data.Text.Fusion.Common as TF +import qualified Data.Text.Internal.Fusion as TF +import qualified Data.Text.Internal.Fusion.Common as TF import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Fusion as TLF -import qualified Data.Text.Lazy.Internal as TL +import qualified Data.Text.Internal.Lazy.Fusion as TLF +import qualified Data.Text.Internal.Lazy as TL import qualified System.IO as IO import Tests.Utils @@ -58,11 +58,19 @@ random = randomR (minBound,maxBound) instance Arbitrary I16 where - arbitrary = choose (minBound,maxBound) + arbitrary = arbitrarySizedIntegral + shrink = shrinkIntegral instance Arbitrary B.ByteString where arbitrary = B.pack `fmap` arbitrary + shrink = map B.pack . shrink . B.unpack +#if !MIN_VERSION_base(4,4,0) +instance Random Word8 where + randomR = integralRandomR + random = randomR (minBound,maxBound) +#endif + genUnicode :: IsString a => Gen a genUnicode = fmap fromString string where string = sized $ \n -> @@ -124,9 +132,11 @@ instance Arbitrary T.Text where arbitrary = T.pack `fmap` arbitrary + shrink = map T.pack . shrink . T.unpack instance Arbitrary TL.Text where arbitrary = (TL.fromChunks . map notEmpty) `fmap` smallArbitrary + shrink = map TL.pack . shrink . TL.unpack newtype NotEmpty a = NotEmpty { notEmpty :: a } deriving (Eq, Ord) @@ -139,16 +149,24 @@ instance Arbitrary a => Arbitrary (NotEmpty [a]) where arbitrary = sized (\n -> NotEmpty `fmap` (choose (1,n+1) >>= vector)) + shrink = shrinkNotEmpty null instance Arbitrary (NotEmpty T.Text) where arbitrary = (fmap T.pack) `fmap` arbitrary + shrink = shrinkNotEmpty T.null instance Arbitrary (NotEmpty TL.Text) where arbitrary = (fmap TL.pack) `fmap` arbitrary + shrink = shrinkNotEmpty TL.null instance Arbitrary (NotEmpty B.ByteString) where arbitrary = (fmap B.pack) `fmap` arbitrary + shrink = shrinkNotEmpty B.null +shrinkNotEmpty :: Arbitrary a => (a -> Bool) -> NotEmpty a -> [NotEmpty a] +shrinkNotEmpty isNull (NotEmpty xs) = + [ NotEmpty xs' | xs' <- shrink xs, not (isNull xs') ] + data Small = S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7 | S8 | S9 | S10 | S11 | S12 | S13 | S14 | S15 | S16 | S17 | S18 | S19 | S20 | S21 | S22 | S23 @@ -188,7 +206,8 @@ random = randomR (minBound,maxBound) instance Arbitrary Small where - arbitrary = choose (minBound,maxBound) + arbitrary = choose (minBound, maxBound) + shrink = shrinkIntegral integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, diff --git a/tests/text-tests.cabal b/tests/text-tests.cabal --- a/tests/text-tests.cabal +++ b/tests/text-tests.cabal @@ -30,6 +30,7 @@ -fhpc cpp-options: + -DTEST_SUITE -DASSERTS -DHAVE_DEEPSEQ @@ -70,49 +71,50 @@ Data.Text.Array Data.Text.Encoding Data.Text.Encoding.Error - Data.Text.Encoding.Fusion - Data.Text.Encoding.Fusion.Common - Data.Text.Encoding.Utf16 - Data.Text.Encoding.Utf32 - Data.Text.Encoding.Utf8 + Data.Text.Internal.Encoding.Fusion + Data.Text.Internal.Encoding.Fusion.Common + Data.Text.Internal.Encoding.Utf16 + Data.Text.Internal.Encoding.Utf32 + Data.Text.Internal.Encoding.Utf8 Data.Text.Foreign - Data.Text.Fusion - Data.Text.Fusion.CaseMapping - Data.Text.Fusion.Common - Data.Text.Fusion.Internal - Data.Text.Fusion.Size + Data.Text.Internal.Fusion + Data.Text.Internal.Fusion.CaseMapping + Data.Text.Internal.Fusion.Common + Data.Text.Internal.Fusion.Size + Data.Text.Internal.Fusion.Types Data.Text.IO - Data.Text.IO.Internal + Data.Text.Internal.IO Data.Text.Internal Data.Text.Lazy Data.Text.Lazy.Builder - Data.Text.Lazy.Builder.Functions + Data.Text.Internal.Builder.Functions Data.Text.Lazy.Builder.Int - Data.Text.Lazy.Builder.Int.Digits - Data.Text.Lazy.Builder.Internal + Data.Text.Internal.Builder.Int.Digits + Data.Text.Internal.Builder Data.Text.Lazy.Builder.RealFloat - Data.Text.Lazy.Builder.RealFloat.Functions + Data.Text.Internal.Builder.RealFloat.Functions Data.Text.Lazy.Encoding - Data.Text.Lazy.Encoding.Fusion - Data.Text.Lazy.Fusion + Data.Text.Internal.Lazy.Encoding.Fusion + Data.Text.Internal.Lazy.Fusion Data.Text.Lazy.IO - Data.Text.Lazy.Internal + Data.Text.Internal.Lazy Data.Text.Lazy.Read - Data.Text.Lazy.Search - Data.Text.Private + Data.Text.Internal.Lazy.Search + Data.Text.Internal.Private Data.Text.Read - Data.Text.Search + Data.Text.Internal.Search Data.Text.Unsafe - Data.Text.Unsafe.Base - Data.Text.UnsafeChar - Data.Text.UnsafeShift - Data.Text.Util + Data.Text.Internal.Unsafe + Data.Text.Internal.Unsafe.Char + Data.Text.Internal.Unsafe.Shift + Data.Text.Internal.Functions if flag(hpc) ghc-options: -fhpc cpp-options: + -DTEST_SUITE -DHAVE_DEEPSEQ -DASSERTS -DINTEGER_GMP diff --git a/text.cabal b/text.cabal --- a/text.cabal +++ b/text.cabal @@ -1,5 +1,5 @@ name: text -version: 1.0.0.1 +version: 1.1.0.0 homepage: https://github.com/bos/text bug-reports: https://github.com/bos/text/issues synopsis: An efficient packed Unicode text type. @@ -82,6 +82,31 @@ Data.Text.Foreign Data.Text.IO Data.Text.Internal + Data.Text.Internal.Builder + Data.Text.Internal.Builder.Functions + Data.Text.Internal.Builder.Int.Digits + Data.Text.Internal.Builder.RealFloat.Functions + Data.Text.Internal.Encoding.Fusion + Data.Text.Internal.Encoding.Fusion.Common + Data.Text.Internal.Encoding.Utf16 + Data.Text.Internal.Encoding.Utf32 + Data.Text.Internal.Encoding.Utf8 + Data.Text.Internal.Functions + Data.Text.Internal.Fusion + Data.Text.Internal.Fusion.CaseMapping + Data.Text.Internal.Fusion.Common + Data.Text.Internal.Fusion.Size + Data.Text.Internal.Fusion.Types + Data.Text.Internal.IO + Data.Text.Internal.Lazy + Data.Text.Internal.Lazy.Encoding.Fusion + Data.Text.Internal.Lazy.Fusion + Data.Text.Internal.Lazy.Search + Data.Text.Internal.Private + Data.Text.Internal.Search + Data.Text.Internal.Unsafe + Data.Text.Internal.Unsafe.Char + Data.Text.Internal.Unsafe.Shift Data.Text.Lazy Data.Text.Lazy.Builder Data.Text.Lazy.Builder.Int @@ -92,39 +117,18 @@ Data.Text.Lazy.Read Data.Text.Read Data.Text.Unsafe - other-modules: - Data.Text.Encoding.Fusion - Data.Text.Encoding.Fusion.Common - Data.Text.Encoding.Utf16 - Data.Text.Encoding.Utf32 - Data.Text.Encoding.Utf8 - Data.Text.Fusion - Data.Text.Fusion.CaseMapping - Data.Text.Fusion.Common - Data.Text.Fusion.Internal - Data.Text.Fusion.Size - Data.Text.IO.Internal - Data.Text.Lazy.Builder.Functions - Data.Text.Lazy.Builder.Int.Digits - Data.Text.Lazy.Builder.Internal - Data.Text.Lazy.Builder.RealFloat.Functions - Data.Text.Lazy.Encoding.Fusion - Data.Text.Lazy.Fusion - Data.Text.Lazy.Search - Data.Text.Private - Data.Text.Search - Data.Text.Unsafe.Base - Data.Text.UnsafeChar - Data.Text.UnsafeShift - Data.Text.Util build-depends: array >= 0.3, base >= 4.2 && < 5, - bytestring >= 0.9, deepseq >= 1.1.0.0, ghc-prim >= 0.2 + if impl(ghc >= 7.7) + build-depends: bytestring >= 0.10.4.0 + else + build-depends: bytestring >= 0.9 + cpp-options: -DHAVE_DEEPSEQ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 if flag(developer) @@ -150,7 +154,7 @@ -Wall -threaded -O0 -rtsopts cpp-options: - -DASSERTS -DHAVE_DEEPSEQ + -DASSERTS -DHAVE_DEEPSEQ -DTEST_SUITE build-depends: HUnit >= 1.2,