git.iko.soy/text
on afba704 help sign in
text/Data/Text/Encoding/Fusion.hs
330 lines 13 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 !a !b !c !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 = error "bsStream: bad UTF-8 stream"
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 = error $ "bsStream: bad UTF-16LE stream"
104 where
105 x1 = (shiftL (idx (i + 1)) 8) + (idx i)
106 x2 = (shiftL (idx (i + 3)) 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 = error $ "bsStream: bad UTF16-BE stream "
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 = error "bsStream: bad UTF-32BE stream"
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 = error "bsStream: bad UTF-32LE stream"
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 #-}
172-- | /O(n)/ Convert a Stream Char into a UTF-8 encoded Stream Word8.
173restreamUtf8 :: Stream Char -> Stream Word8
174restreamUtf8 (Stream next0 s0 len) =
175 Stream next (T4 (Just s0) Nothing Nothing Nothing) (len*2)
176 where
177 {-# INLINE next #-}
178 next (T4 (Just s) Nothing Nothing Nothing) = case next0 s of
179 Done -> Done
180 Skip s' -> Skip (T4 (Just s') Nothing Nothing Nothing)
181 Yield x xs
182 | n <= 0x7F -> Yield c (T4 (Just xs) Nothing Nothing Nothing)
183 | n <= 0x07FF -> Yield (fst c2) (T4 (Just xs) (Just $ snd c2) Nothing Nothing)
184 | n <= 0xFFFF -> Yield (fst3 c3) (T4 (Just xs) (Just $ snd3 c3) (Just $ trd3 c3) Nothing)
185 | otherwise -> Yield (fst4 c4) (T4 (Just xs) (Just $ snd4 c4) (Just $ trd4 c4) (Just $ fth4 c4))
186 where
187 n = ord x
188 c = fromIntegral n
189 c2 = U8.ord2 x
190 c3 = U8.ord3 x
191 c4 = U8.ord4 x
192 fst3 (x1,_,_) = x1
193 snd3 (_,x2,_) = x2
194 trd3 (_,_,x3) = x3
195 fst4 (x1,_,_,_) = x1
196 snd4 (_,x2,_,_) = x2
197 trd4 (_,_,x3,_) = x3
198 fth4 (_,_,_,x4) = x4
199 next (T4 (Just s) (Just x2) Nothing Nothing) = Yield x2 (T4 (Just s) Nothing Nothing Nothing)
200 next (T4 (Just s) (Just x2) x3 Nothing) = Yield x2 (T4 (Just s) x3 Nothing Nothing)
201 next (T4 (Just s) (Just x2) x3 x4) = Yield x2 (T4 (Just s) x3 x4 Nothing)
202 next _ = internalError "restreamUtf8"
203{-# INLINE restreamUtf8 #-}
205restreamUtf16BE :: Stream Char -> Stream Word8
206restreamUtf16BE (Stream next0 s0 len) =
207 Stream next (T4 (Just s0) Nothing Nothing Nothing) (len*2)
208 where
209 {-# INLINE next #-}
210 next (T4 (Just s) Nothing Nothing Nothing) = case next0 s of
211 Done -> Done
212 Skip s' -> Skip (T4 (Just s') Nothing Nothing Nothing)
213 Yield x xs
214 | n < 0x10000 -> Yield (fromIntegral $ shiftR n 8) (T4 (Just xs) (Just (fromIntegral n)) Nothing Nothing)
215 | otherwise -> Yield c1 (T4 (Just xs) (Just c2) (Just c3) (Just c4))
216 where
217 n = ord x
218 n1 = n - 0x10000
219 c1 = fromIntegral (shiftR n1 18 + 0xD8)
220 c2 = fromIntegral (shiftR n1 10)
221 n2 = n1 .&. 0x3FF
222 c3 = fromIntegral (shiftR n2 8 + 0xDC)
223 c4 = fromIntegral n2
224 next (T4 (Just s) (Just x2) Nothing Nothing) = Yield x2 (T4 (Just s) Nothing Nothing Nothing)
225 next (T4 (Just s) (Just x2) x3 Nothing) = Yield x2 (T4 (Just s) x3 Nothing Nothing)
226 next (T4 (Just s) (Just x2) x3 x4) = Yield x2 (T4 (Just s) x3 x4 Nothing)
227 next _ = internalError "restreamUtf16BE"
228{-# INLINE restreamUtf16BE #-}
230restreamUtf16LE :: Stream Char -> Stream Word8
231restreamUtf16LE (Stream next0 s0 len) =
232 Stream next (T4 (Just s0) Nothing Nothing Nothing) (len*2)
233 where
234 {-# INLINE next #-}
235 next (T4 (Just s) Nothing Nothing Nothing) = case next0 s of
236 Done -> Done
237 Skip s' -> Skip (T4 (Just s') Nothing Nothing Nothing)
238 Yield x xs
239 | n < 0x10000 -> Yield (fromIntegral n) (T4 (Just xs) (Just (fromIntegral $ shiftR n 8)) Nothing Nothing)
240 | otherwise -> Yield c1 (T4 (Just xs) (Just c2) (Just c3) (Just c4))
241 where
242 n = ord x
243 n1 = n - 0x10000
244 c2 = fromIntegral (shiftR n1 18 + 0xD8)
245 c1 = fromIntegral (shiftR n1 10)
246 n2 = n1 .&. 0x3FF
247 c4 = fromIntegral (shiftR n2 8 + 0xDC)
248 c3 = fromIntegral n2
249 next (T4 (Just s) (Just x2) Nothing Nothing) = Yield x2 (T4 (Just s) Nothing Nothing Nothing)
250 next (T4 (Just s) (Just x2) x3 Nothing) = Yield x2 (T4 (Just s) x3 Nothing Nothing)
251 next (T4 (Just s) (Just x2) x3 x4) = Yield x2 (T4 (Just s) x3 x4 Nothing)
252 next _ = internalError "restreamUtf16LE"
253{-# INLINE restreamUtf16LE #-}
255restreamUtf32BE :: Stream Char -> Stream Word8
256restreamUtf32BE (Stream next0 s0 len) =
257 Stream next (T4 (Just s0) Nothing Nothing Nothing) (len*2)
258 where
259 {-# INLINE next #-}
260 next (T4 (Just s) Nothing Nothing Nothing) = case next0 s of
261 Done -> Done
262 Skip s' -> Skip (T4 (Just s') Nothing Nothing Nothing)
263 Yield x xs -> Yield c1 (T4 (Just xs) (Just c2) (Just c3) (Just c4))
264 where
265 n = ord x
266 c1 = fromIntegral $ shiftR n 24
267 c2 = fromIntegral $ shiftR n 16
268 c3 = fromIntegral $ shiftR n 8
269 c4 = fromIntegral n
270 next (T4 (Just s) (Just x2) Nothing Nothing) = Yield x2 (T4 (Just s) Nothing Nothing Nothing)
271 next (T4 (Just s) (Just x2) x3 Nothing) = Yield x2 (T4 (Just s) x3 Nothing Nothing)
272 next (T4 (Just s) (Just x2) x3 x4) = Yield x2 (T4 (Just s) x3 x4 Nothing)
273 next _ = internalError "restreamUtf32BE"
274{-# INLINE restreamUtf32BE #-}
276restreamUtf32LE :: Stream Char -> Stream Word8
277restreamUtf32LE (Stream next0 s0 len) =
278 Stream next (T4 (Just s0) Nothing Nothing Nothing) (len*2)
279 where
280 {-# INLINE next #-}
281 next (T4 (Just s) Nothing Nothing Nothing) = case next0 s of
282 Done -> Done
283 Skip s' -> Skip (T4 (Just s') Nothing Nothing Nothing)
284 Yield x xs -> Yield c1 (T4 (Just xs) (Just c2) (Just c3) (Just c4))
285 where
286 n = ord x
287 c4 = fromIntegral $ shiftR n 24
288 c3 = fromIntegral $ shiftR n 16
289 c2 = fromIntegral $ shiftR n 8
290 c1 = fromIntegral n
291 next (T4 (Just s) (Just x2) Nothing Nothing) = Yield x2 (T4 (Just s) Nothing Nothing Nothing)
292 next (T4 (Just s) (Just x2) x3 Nothing) = Yield x2 (T4 (Just s) x3 Nothing Nothing)
293 next (T4 (Just s) (Just x2) x3 x4) = Yield x2 (T4 (Just s) x3 x4 Nothing)
294 next _ = internalError "restreamUtf32LE"
295{-# INLINE restreamUtf32LE #-}
298-- | /O(n)/ Convert a 'Stream' 'Word8' to a 'ByteString'.
299unstream :: Stream Word8 -> ByteString
300unstream (Stream next s0 len) = unsafePerformIO $ do
301 fp0 <- mallocByteString len
302 loop fp0 len 0 s0
303 where
304 loop !fp !n !off !s = case next s of
305 Done -> trimUp fp n off
306 Skip s' -> loop fp n off s'
307 Yield x s'
308 | n == off -> realloc fp n off s' x
309 | otherwise -> do
310 withForeignPtr fp $ \p -> pokeByteOff p off x
311 loop fp n (off+1) s'
312 {-# NOINLINE realloc #-}
313 realloc fp n off s x = do
314 let n' = n+n
315 fp' <- copy0 fp n n'
316 withForeignPtr fp' $ \p -> pokeByteOff p off x
317 loop fp' n' (off+1) s
318 {-# NOINLINE trimUp #-}
319 trimUp fp _ off = return $! PS fp 0 off
320 copy0 :: ForeignPtr Word8 -> Int -> Int -> IO (ForeignPtr Word8)
321 copy0 !src !srcLen !destLen = assert (srcLen <= destLen) $ do
322 dest <- mallocByteString destLen
323 withForeignPtr src $ \src' ->
324 withForeignPtr dest $ \dest' ->
325 memcpy dest' src' (fromIntegral destLen)
326 return dest
328internalError :: String -> a
329internalError func =
330 error $ "Data.Text.Encoding.Fusion." ++ func ++ ": internal error"