git.iko.soy/text
on 94df678 help sign in
text/Data/Text/Encoding/Fusion.hs
332 lines 12 kB history raw
1{-# LANGUAGE BangPatterns #-}
3-- |
4-- Module : Data.Text.Encoding
5-- Copyright : (c) Tom Harper 2008-2009,
6-- (c) Bryan O'Sullivan 2009,
7-- (c) Duncan Coutts 2009
8--
9-- License : BSD-style
10-- Maintainer : rtharper@aftereternity.co.uk, bos@serpentine.com,
11-- duncan@haskell.org
12-- Stability : experimental
13-- Portability : portable
14--
15-- Fusible 'Stream'-oriented functions for converting between 'Text'
16-- and several common encodings.
18module Data.Text.Encoding.Fusion
19 (
20 -- * Streaming
21 streamASCII
22 , streamUtf8
23 , streamUtf16LE
24 , streamUtf16BE
25 , streamUtf32LE
26 , streamUtf32BE
28 -- * Unstreaming
29 , unstream
31 -- * Restreaming
32 -- Restreaming is the act of converting from one 'Stream'
33 -- representation to another.
34 , restreamASCII
35 , restreamUtf8
36 , restreamUtf16LE
37 , restreamUtf16BE
38 , restreamUtf32LE
39 , restreamUtf32BE
40 ) where
42import Control.Exception (assert)
43import Data.Bits (shiftL, shiftR, (.&.))
44import Data.ByteString as B
45import Data.ByteString.Internal (ByteString(..), mallocByteString, memcpy)
46import Data.Char (ord)
47import Data.Text.Fusion (Step(..), Stream(..))
48import Data.Text.UnsafeChar (unsafeChr, unsafeChr8, unsafeChr32)
49import Data.Word (Word8, Word16, Word32)
50import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)
51import Foreign.Storable (pokeByteOff)
52import System.IO.Unsafe (unsafePerformIO)
53import qualified Data.ByteString as B
54import qualified Data.ByteString.Unsafe as B
55import qualified Data.Text.Utf16 as U16
56import qualified Data.Text.Utf32 as U32
57import qualified Data.Text.Utf8 as U8
59data T4 a b c d = T4 {-# UNPACK #-} !a {-# UNPACK #-} !b {-# UNPACK #-} !c {-# UNPACK #-} !d
61streamASCII :: ByteString -> Stream Char
62streamASCII bs = Stream next 0 l
63 where
64 l = B.length bs
65 {-# INLINE next #-}
66 next i
67 | i >= l = Done
68 | otherwise = Yield (unsafeChr8 x1) (i+1)
69 where
70 x1 = B.unsafeIndex bs i
71{-# INLINE [0] streamASCII #-}
73-- | /O(n) Convert a ByteString into a Stream Char, using the specified encoding standard.
74streamUtf8 :: ByteString -> Stream Char
75streamUtf8 bs = Stream next 0 l
76 where
77 l = B.length bs
78 {-# INLINE next #-}
79 next i
80 | i >= l = Done
81 | U8.validate1 x1 = Yield (unsafeChr8 x1) (i+1)
82 | i+1 < l && U8.validate2 x1 x2 = Yield (U8.chr2 x1 x2) (i+2)
83 | i+2 < l && U8.validate3 x1 x2 x3 = Yield (U8.chr3 x1 x2 x3) (i+3)
84 | i+3 < l && U8.validate4 x1 x2 x3 x4 = Yield (U8.chr4 x1 x2 x3 x4) (i+4)
85 | otherwise = encodingError "UTF-8"
86 where
87 x1 = idx i
88 x2 = idx (i + 1)
89 x3 = idx (i + 2)
90 x4 = idx (i + 3)
91 idx = B.unsafeIndex bs
92{-# INLINE [0] streamUtf8 #-}
94streamUtf16LE :: ByteString -> Stream Char
95streamUtf16LE bs = Stream next 0 l
96 where
97 l = B.length bs
98 {-# INLINE next #-}
99 next i
100 | i >= l = Done
101 | i+1 < l && U16.validate1 x1 = Yield (unsafeChr x1) (i+2)
102 | i+3 < l && U16.validate2 x1 x2 = Yield (U16.chr2 x1 x2) (i+4)
103 | otherwise = encodingError "UTF-16LE"
104 where
105 x1 = (idx (i + 1) `shiftL` 8) + idx i
106 x2 = (idx (i + 3) `shiftL` 8) + idx (i + 2)
107 idx = fromIntegral . B.unsafeIndex bs :: Int -> Word16
108{-# INLINE [0] streamUtf16LE #-}
110streamUtf16BE :: ByteString -> Stream Char
111streamUtf16BE bs = Stream next 0 l
112 where
113 l = B.length bs
114 {-# INLINE next #-}
115 next i
116 | i >= l = Done
117 | i+1 < l && U16.validate1 x1 = Yield (unsafeChr x1) (i+2)
118 | i+3 < l && U16.validate2 x1 x2 = Yield (U16.chr2 x1 x2) (i+4)
119 | otherwise = encodingError "UTF16-BE"
120 where
121 x1 = (shiftL (idx i) 8) + (idx (i + 1))
122 x2 = (shiftL (idx (i + 2)) 8) + (idx (i + 3))
123 idx = fromIntegral . B.unsafeIndex bs :: Int -> Word16
124{-# INLINE [0] streamUtf16BE #-}
126streamUtf32BE :: ByteString -> Stream Char
127streamUtf32BE bs = Stream next 0 l
128 where
129 l = B.length bs
130 {-# INLINE next #-}
131 next i
132 | i >= l = Done
133 | i+3 < l && U32.validate x = Yield (unsafeChr32 x) (i+4)
134 | otherwise = encodingError "UTF-32BE"
135 where
136 x = shiftL x1 24 + shiftL x2 16 + shiftL x3 8 + x4
137 x1 = idx i
138 x2 = idx (i+1)
139 x3 = idx (i+2)
140 x4 = idx (i+3)
141 idx = fromIntegral . B.unsafeIndex bs :: Int -> Word32
142{-# INLINE [0] streamUtf32BE #-}
144streamUtf32LE :: ByteString -> Stream Char
145streamUtf32LE bs = Stream next 0 l
146 where
147 l = B.length bs
148 {-# INLINE next #-}
149 next i
150 | i >= l = Done
151 | i+3 < l && U32.validate x = Yield (unsafeChr32 x) (i+4)
152 | otherwise = encodingError "UTF-32LE"
153 where
154 x = shiftL x4 24 + shiftL x3 16 + shiftL x2 8 + x1
155 x1 = idx i
156 x2 = idx $ i+1
157 x3 = idx $ i+2
158 x4 = idx $ i+3
159 idx = fromIntegral . B.unsafeIndex bs :: Int -> Word32
160{-# INLINE [0] streamUtf32LE #-}
162restreamASCII :: Stream Char -> Stream Word8
163restreamASCII (Stream next0 s0 len) = Stream next s0 (len*2)
164 where
165 next !s = case next0 s of
166 Done -> Done
167 Skip s' -> Skip s'
168 Yield x xs -> Yield x' xs
169 where x' = fromIntegral (ord x) :: Word8
170{-# INLINE restreamASCII #-}
172data M = N | J {-# UNPACK #-} !Word8
173 deriving (Eq, Ord, Show)
175-- | /O(n)/ Convert a Stream Char into a UTF-8 encoded Stream Word8.
176restreamUtf8 :: Stream Char -> Stream Word8
177restreamUtf8 (Stream next0 s0 len) =
178 Stream next (T4 s0 N N N) (len*2)
179 where
180 {-# INLINE next #-}
181 next (T4 s N N N) = case next0 s of
182 Done -> Done
183 Skip s' -> Skip (T4 s' N N N)
184 Yield x xs
185 | n <= 0x7F -> Yield c (T4 xs N N N)
186 | n <= 0x07FF -> Yield a2 (T4 xs (J b2) N N)
187 | n <= 0xFFFF -> Yield a3 (T4 xs (J b3) (J c3) N)
188 | otherwise -> Yield a4 (T4 xs (J b4) (J c4) (J d4))
189 where
190 n = ord x
191 c = fromIntegral n
192 (a2,b2) = U8.ord2 x
193 (a3,b3,c3) = U8.ord3 x
194 (a4,b4,c4,d4) = U8.ord4 x
195 next (T4 s (J x2) N N) = Yield x2 (T4 s N N N)
196 next (T4 s (J x2) x3 N) = Yield x2 (T4 s x3 N N)
197 next (T4 s (J x2) x3 x4) = Yield x2 (T4 s x3 x4 N)
198 next _ = internalError "restreamUtf8"
199{-# INLINE restreamUtf8 #-}
201restreamUtf16BE :: Stream Char -> Stream Word8
202restreamUtf16BE (Stream next0 s0 len) =
203 Stream next (T4 s0 N N N) (len*2)
204 where
205 {-# INLINE next #-}
206 next (T4 s N N N) = case next0 s of
207 Done -> Done
208 Skip s' -> Skip (T4 s' N N N)
209 Yield x xs
210 | n < 0x10000 -> Yield (fromIntegral $ shiftR n 8) (T4 xs (J (fromIntegral n)) N N)
211 | otherwise -> Yield c1 (T4 xs (J c2) (J c3) (J c4))
212 where
213 n = ord x
214 n1 = n - 0x10000
215 c1 = fromIntegral (shiftR n1 18 + 0xD8)
216 c2 = fromIntegral (shiftR n1 10)
217 n2 = n1 .&. 0x3FF
218 c3 = fromIntegral (shiftR n2 8 + 0xDC)
219 c4 = fromIntegral n2
220 next (T4 s (J x2) N N) = Yield x2 (T4 s N N N)
221 next (T4 s (J x2) x3 N) = Yield x2 (T4 s x3 N N)
222 next (T4 s (J x2) x3 x4) = Yield x2 (T4 s x3 x4 N)
223 next _ = internalError "restreamUtf16BE"
224{-# INLINE restreamUtf16BE #-}
226restreamUtf16LE :: Stream Char -> Stream Word8
227restreamUtf16LE (Stream next0 s0 len) =
228 Stream next (T4 s0 N N N) (len*2)
229 where
230 {-# INLINE next #-}
231 next (T4 s N N N) = case next0 s of
232 Done -> Done
233 Skip s' -> Skip (T4 s' N N N)
234 Yield x xs
235 | n < 0x10000 -> Yield (fromIntegral n) $
236 T4 xs (J (fromIntegral $ shiftR n 8)) N N
237 | otherwise -> Yield c1 $
238 T4 xs (J c2) (J c3) (J c4)
239 where
240 n = ord x
241 n1 = n - 0x10000
242 c2 = fromIntegral (shiftR n1 18 + 0xD8)
243 c1 = fromIntegral (shiftR n1 10)
244 n2 = n1 .&. 0x3FF
245 c4 = fromIntegral (shiftR n2 8 + 0xDC)
246 c3 = fromIntegral n2
247 next (T4 s (J x2) N N) = Yield x2 (T4 s N N N)
248 next (T4 s (J x2) x3 N) = Yield x2 (T4 s x3 N N)
249 next (T4 s (J x2) x3 x4) = Yield x2 (T4 s x3 x4 N)
250 next _ = internalError "restreamUtf16LE"
251{-# INLINE restreamUtf16LE #-}
253restreamUtf32BE :: Stream Char -> Stream Word8
254restreamUtf32BE (Stream next0 s0 len) =
255 Stream next (T4 (Just s0) Nothing Nothing Nothing) (len*2)
256 where
257 {-# INLINE next #-}
258 next (T4 (Just s) Nothing Nothing Nothing) = case next0 s of
259 Done -> Done
260 Skip s' -> Skip (T4 (Just s') Nothing Nothing Nothing)
261 Yield x xs -> Yield c1 (T4 (Just xs) (Just c2) (Just c3) (Just c4))
262 where
263 n = ord x
264 c1 = fromIntegral $ shiftR n 24
265 c2 = fromIntegral $ shiftR n 16
266 c3 = fromIntegral $ shiftR n 8
267 c4 = fromIntegral n
268 next (T4 (Just s) (Just x2) Nothing Nothing) = Yield x2 (T4 (Just s) Nothing Nothing Nothing)
269 next (T4 (Just s) (Just x2) x3 Nothing) = Yield x2 (T4 (Just s) x3 Nothing Nothing)
270 next (T4 (Just s) (Just x2) x3 x4) = Yield x2 (T4 (Just s) x3 x4 Nothing)
271 next _ = internalError "restreamUtf32BE"
272{-# INLINE restreamUtf32BE #-}
274restreamUtf32LE :: Stream Char -> Stream Word8
275restreamUtf32LE (Stream next0 s0 len) =
276 Stream next (T4 (Just s0) Nothing Nothing Nothing) (len*2)
277 where
278 {-# INLINE next #-}
279 next (T4 (Just s) Nothing Nothing Nothing) = case next0 s of
280 Done -> Done
281 Skip s' -> Skip (T4 (Just s') Nothing Nothing Nothing)
282 Yield x xs -> Yield c1 (T4 (Just xs) (Just c2) (Just c3) (Just c4))
283 where
284 n = ord x
285 c4 = fromIntegral $ shiftR n 24
286 c3 = fromIntegral $ shiftR n 16
287 c2 = fromIntegral $ shiftR n 8
288 c1 = fromIntegral n
289 next (T4 (Just s) (Just x2) Nothing Nothing) = Yield x2 (T4 (Just s) Nothing Nothing Nothing)
290 next (T4 (Just s) (Just x2) x3 Nothing) = Yield x2 (T4 (Just s) x3 Nothing Nothing)
291 next (T4 (Just s) (Just x2) x3 x4) = Yield x2 (T4 (Just s) x3 x4 Nothing)
292 next _ = internalError "restreamUtf32LE"
293{-# INLINE restreamUtf32LE #-}
296-- | /O(n)/ Convert a 'Stream' 'Word8' to a 'ByteString'.
297unstream :: Stream Word8 -> ByteString
298unstream (Stream next s0 len) = unsafePerformIO $ do
299 fp0 <- mallocByteString len
300 loop fp0 len 0 s0
301 where
302 loop !fp !n !off !s = case next s of
303 Done -> trimUp fp n off
304 Skip s' -> loop fp n off s'
305 Yield x s'
306 | n == off -> realloc fp n off s' x
307 | otherwise -> do
308 withForeignPtr fp $ \p -> pokeByteOff p off x
309 loop fp n (off+1) s'
310 {-# NOINLINE realloc #-}
311 realloc fp n off s x = do
312 let n' = n+n
313 fp' <- copy0 fp n n'
314 withForeignPtr fp' $ \p -> pokeByteOff p off x
315 loop fp' n' (off+1) s
316 {-# NOINLINE trimUp #-}
317 trimUp fp _ off = return $! PS fp 0 off
318 copy0 :: ForeignPtr Word8 -> Int -> Int -> IO (ForeignPtr Word8)
319 copy0 !src !srcLen !destLen = assert (srcLen <= destLen) $ do
320 dest <- mallocByteString destLen
321 withForeignPtr src $ \src' ->
322 withForeignPtr dest $ \dest' ->
323 memcpy dest' src' (fromIntegral destLen)
324 return dest
326internalError :: String -> a
327internalError func =
328 error $ "Data.Text.Encoding.Fusion." ++ func ++ ": internal error"
330encodingError :: String -> a
331encodingError encoding =
332 error $ "Data.Text.Encoding.Fusion: Bad " ++ encoding ++ " stream"