1cf8092c67a488c90f21f6fe0d635f034393c512
[packages/base.git] / GHC / IO / Encoding / UTF8.hs
1 {-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-}
2 {-# LANGUAGE BangPatterns #-}
3 -----------------------------------------------------------------------------
4 -- |
5 -- Module : GHC.IO.Encoding.UTF8
6 -- Copyright : (c) The University of Glasgow, 2009
7 -- License : see libraries/base/LICENSE
8 --
9 -- Maintainer : libraries@haskell.org
10 -- Stability : internal
11 -- Portability : non-portable
12 --
13 -- UTF-8 Codec for the IO library
14 --
15 -- Portions Copyright : (c) Tom Harper 2008-2009,
16 -- (c) Bryan O'Sullivan 2009,
17 -- (c) Duncan Coutts 2009
18 --
19 -----------------------------------------------------------------------------
20
21 module GHC.IO.Encoding.UTF8 (
22 utf8,
23 utf8_bom,
24 ) where
25
26 import GHC.Base
27 import GHC.Real
28 import GHC.Num
29 import GHC.IORef
30 -- import GHC.IO
31 import GHC.IO.Exception
32 import GHC.IO.Buffer
33 import GHC.IO.Encoding.Types
34 import GHC.Word
35 import Data.Bits
36 import Data.Maybe
37
38 utf8 :: TextEncoding
39 utf8 = TextEncoding { textEncodingName = "UTF-8",
40 mkTextDecoder = utf8_DF,
41 mkTextEncoder = utf8_EF }
42
43 utf8_DF :: IO (TextDecoder ())
44 utf8_DF =
45 return (BufferCodec {
46 encode = utf8_decode,
47 close = return (),
48 getState = return (),
49 setState = const $ return ()
50 })
51
52 utf8_EF :: IO (TextEncoder ())
53 utf8_EF =
54 return (BufferCodec {
55 encode = utf8_encode,
56 close = return (),
57 getState = return (),
58 setState = const $ return ()
59 })
60
61 utf8_bom :: TextEncoding
62 utf8_bom = TextEncoding { textEncodingName = "UTF-8BOM",
63 mkTextDecoder = utf8_bom_DF,
64 mkTextEncoder = utf8_bom_EF }
65
66 utf8_bom_DF :: IO (TextDecoder Bool)
67 utf8_bom_DF = do
68 ref <- newIORef True
69 return (BufferCodec {
70 encode = utf8_bom_decode ref,
71 close = return (),
72 getState = readIORef ref,
73 setState = writeIORef ref
74 })
75
76 utf8_bom_EF :: IO (TextEncoder Bool)
77 utf8_bom_EF = do
78 ref <- newIORef True
79 return (BufferCodec {
80 encode = utf8_bom_encode ref,
81 close = return (),
82 getState = readIORef ref,
83 setState = writeIORef ref
84 })
85
86 utf8_bom_decode :: IORef Bool -> DecodeBuffer
87 utf8_bom_decode ref
88 input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ }
89 output
90 = do
91 first <- readIORef ref
92 if not first
93 then utf8_decode input output
94 else do
95 let no_bom = do writeIORef ref False; utf8_decode input output
96 if iw - ir < 1 then return (input,output) else do
97 c0 <- readWord8Buf iraw ir
98 if (c0 /= bom0) then no_bom else do
99 if iw - ir < 2 then return (input,output) else do
100 c1 <- readWord8Buf iraw (ir+1)
101 if (c1 /= bom1) then no_bom else do
102 if iw - ir < 3 then return (input,output) else do
103 c2 <- readWord8Buf iraw (ir+2)
104 if (c2 /= bom2) then no_bom else do
105 -- found a BOM, ignore it and carry on
106 writeIORef ref False
107 utf8_decode input{ bufL = ir + 3 } output
108
109 utf8_bom_encode :: IORef Bool -> EncodeBuffer
110 utf8_bom_encode ref input
111 output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os }
112 = do
113 b <- readIORef ref
114 if not b then utf8_encode input output
115 else if os - ow < 3
116 then return (input,output)
117 else do
118 writeIORef ref False
119 writeWord8Buf oraw ow bom0
120 writeWord8Buf oraw (ow+1) bom1
121 writeWord8Buf oraw (ow+2) bom2
122 utf8_encode input output{ bufR = ow+3 }
123
124 bom0, bom1, bom2 :: Word8
125 bom0 = 0xef
126 bom1 = 0xbb
127 bom2 = 0xbf
128
129 utf8_decode :: DecodeBuffer
130 utf8_decode
131 input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
132 output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
133 = let
134 loop !ir !ow
135 | ow >= os || ir >= iw = done ir ow
136 | otherwise = do
137 c0 <- readWord8Buf iraw ir
138 case c0 of
139 _ | c0 <= 0x7f -> do
140 ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0))
141 loop (ir+1) ow'
142 | c0 >= 0xc0 && c0 <= 0xdf ->
143 if iw - ir < 2 then done ir ow else do
144 c1 <- readWord8Buf iraw (ir+1)
145 if (c1 < 0x80 || c1 >= 0xc0) then invalid else do
146 ow' <- writeCharBuf oraw ow (chr2 c0 c1)
147 loop (ir+2) ow'
148 | c0 >= 0xe0 && c0 <= 0xef ->
149 case iw - ir of
150 1 -> done ir ow
151 2 -> do -- check for an error even when we don't have
152 -- the full sequence yet (#3341)
153 c1 <- readWord8Buf iraw (ir+1)
154 if not (validate3 c0 c1 0x80)
155 then invalid else done ir ow
156 _ -> do
157 c1 <- readWord8Buf iraw (ir+1)
158 c2 <- readWord8Buf iraw (ir+2)
159 if not (validate3 c0 c1 c2) then invalid else do
160 ow' <- writeCharBuf oraw ow (chr3 c0 c1 c2)
161 loop (ir+3) ow'
162 | c0 >= 0xf0 ->
163 case iw - ir of
164 1 -> done ir ow
165 2 -> do -- check for an error even when we don't have
166 -- the full sequence yet (#3341)
167 c1 <- readWord8Buf iraw (ir+1)
168 if not (validate4 c0 c1 0x80 0x80)
169 then invalid else done ir ow
170 3 -> do
171 c1 <- readWord8Buf iraw (ir+1)
172 c2 <- readWord8Buf iraw (ir+2)
173 if not (validate4 c0 c1 c2 0x80)
174 then invalid else done ir ow
175 _ -> do
176 c1 <- readWord8Buf iraw (ir+1)
177 c2 <- readWord8Buf iraw (ir+2)
178 c3 <- readWord8Buf iraw (ir+3)
179 if not (validate4 c0 c1 c2 c3) then invalid else do
180 ow' <- writeCharBuf oraw ow (chr4 c0 c1 c2 c3)
181 loop (ir+4) ow'
182 | otherwise ->
183 invalid
184 where
185 invalid = if ir > ir0 then done ir ow else ioe_decodingError
186
187 -- lambda-lifted, to avoid thunks being built in the inner-loop:
188 done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
189 else input{ bufL=ir },
190 output{ bufR=ow })
191 in
192 loop ir0 ow0
193
194 ioe_decodingError :: IO a
195 ioe_decodingError = ioException
196 (IOError Nothing InvalidArgument "utf8_decode"
197 "invalid UTF-8 byte sequence" Nothing Nothing)
198
199 utf8_encode :: EncodeBuffer
200 utf8_encode
201 input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
202 output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
203 = let
204 done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
205 else input{ bufL=ir },
206 output{ bufR=ow })
207 loop !ir !ow
208 | ow >= os || ir >= iw = done ir ow
209 | otherwise = do
210 (c,ir') <- readCharBuf iraw ir
211 case ord c of
212 x | x <= 0x7F -> do
213 writeWord8Buf oraw ow (fromIntegral x)
214 loop ir' (ow+1)
215 | x <= 0x07FF ->
216 if os - ow < 2 then done ir ow else do
217 let (c1,c2) = ord2 c
218 writeWord8Buf oraw ow c1
219 writeWord8Buf oraw (ow+1) c2
220 loop ir' (ow+2)
221 | x <= 0xFFFF -> do
222 if os - ow < 3 then done ir ow else do
223 let (c1,c2,c3) = ord3 c
224 writeWord8Buf oraw ow c1
225 writeWord8Buf oraw (ow+1) c2
226 writeWord8Buf oraw (ow+2) c3
227 loop ir' (ow+3)
228 | otherwise -> do
229 if os - ow < 4 then done ir ow else do
230 let (c1,c2,c3,c4) = ord4 c
231 writeWord8Buf oraw ow c1
232 writeWord8Buf oraw (ow+1) c2
233 writeWord8Buf oraw (ow+2) c3
234 writeWord8Buf oraw (ow+3) c4
235 loop ir' (ow+4)
236 in
237 loop ir0 ow0
238
239 -- -----------------------------------------------------------------------------
240 -- UTF-8 primitives, lifted from Data.Text.Fusion.Utf8
241
242 ord2 :: Char -> (Word8,Word8)
243 ord2 c = assert (n >= 0x80 && n <= 0x07ff) (x1,x2)
244 where
245 n = ord c
246 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
247 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
248
249 ord3 :: Char -> (Word8,Word8,Word8)
250 ord3 c = assert (n >= 0x0800 && n <= 0xffff) (x1,x2,x3)
251 where
252 n = ord c
253 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
254 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
255 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
256
257 ord4 :: Char -> (Word8,Word8,Word8,Word8)
258 ord4 c = assert (n >= 0x10000) (x1,x2,x3,x4)
259 where
260 n = ord c
261 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
262 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
263 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
264 x4 = fromIntegral $ (n .&. 0x3F) + 0x80
265
266 chr2 :: Word8 -> Word8 -> Char
267 chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#))
268 where
269 !y1# = word2Int# x1#
270 !y2# = word2Int# x2#
271 !z1# = uncheckedIShiftL# (y1# -# 0xC0#) 6#
272 !z2# = y2# -# 0x80#
273 {-# INLINE chr2 #-}
274
275 chr3 :: Word8 -> Word8 -> Word8 -> Char
276 chr3 (W8# x1#) (W8# x2#) (W8# x3#) = C# (chr# (z1# +# z2# +# z3#))
277 where
278 !y1# = word2Int# x1#
279 !y2# = word2Int# x2#
280 !y3# = word2Int# x3#
281 !z1# = uncheckedIShiftL# (y1# -# 0xE0#) 12#
282 !z2# = uncheckedIShiftL# (y2# -# 0x80#) 6#
283 !z3# = y3# -# 0x80#
284 {-# INLINE chr3 #-}
285
286 chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char
287 chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) =
288 C# (chr# (z1# +# z2# +# z3# +# z4#))
289 where
290 !y1# = word2Int# x1#
291 !y2# = word2Int# x2#
292 !y3# = word2Int# x3#
293 !y4# = word2Int# x4#
294 !z1# = uncheckedIShiftL# (y1# -# 0xF0#) 18#
295 !z2# = uncheckedIShiftL# (y2# -# 0x80#) 12#
296 !z3# = uncheckedIShiftL# (y3# -# 0x80#) 6#
297 !z4# = y4# -# 0x80#
298 {-# INLINE chr4 #-}
299
300 between :: Word8 -- ^ byte to check
301 -> Word8 -- ^ lower bound
302 -> Word8 -- ^ upper bound
303 -> Bool
304 between x y z = x >= y && x <= z
305 {-# INLINE between #-}
306
307 validate3 :: Word8 -> Word8 -> Word8 -> Bool
308 {-# INLINE validate3 #-}
309 validate3 x1 x2 x3 = validate3_1 ||
310 validate3_2 ||
311 validate3_3 ||
312 validate3_4
313 where
314 validate3_1 = (x1 == 0xE0) &&
315 between x2 0xA0 0xBF &&
316 between x3 0x80 0xBF
317 validate3_2 = between x1 0xE1 0xEC &&
318 between x2 0x80 0xBF &&
319 between x3 0x80 0xBF
320 validate3_3 = x1 == 0xED &&
321 between x2 0x80 0x9F &&
322 between x3 0x80 0xBF
323 validate3_4 = between x1 0xEE 0xEF &&
324 between x2 0x80 0xBF &&
325 between x3 0x80 0xBF
326
327 validate4 :: Word8 -> Word8 -> Word8 -> Word8 -> Bool
328 {-# INLINE validate4 #-}
329 validate4 x1 x2 x3 x4 = validate4_1 ||
330 validate4_2 ||
331 validate4_3
332 where
333 validate4_1 = x1 == 0xF0 &&
334 between x2 0x90 0xBF &&
335 between x3 0x80 0xBF &&
336 between x4 0x80 0xBF
337 validate4_2 = between x1 0xF1 0xF3 &&
338 between x2 0x80 0xBF &&
339 between x3 0x80 0xBF &&
340 between x4 0x80 0xBF
341 validate4_3 = x1 == 0xF4 &&
342 between x2 0x80 0x8F &&
343 between x3 0x80 0xBF &&
344 between x4 0x80 0xBF