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