1 {-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-}
2 {-# LANGUAGE BangPatterns #-}
3 -----------------------------------------------------------------------------
5 -- Module : GHC.IO.Encoding.UTF8
6 -- Copyright : (c) The University of Glasgow, 2009
7 -- License : see libraries/base/LICENSE
9 -- Maintainer : libraries@haskell.org
10 -- Stability : internal
11 -- Portability : non-portable
13 -- UTF-8 Codec for the IO library
15 -- Portions Copyright : (c) Tom Harper 2008-2009,
16 -- (c) Bryan O'Sullivan 2009,
17 -- (c) Duncan Coutts 2009
19 -----------------------------------------------------------------------------
21 module GHC.IO.Encoding.UTF8 (
31 import GHC.IO.Exception
33 import GHC.IO.Encoding.Types
39 utf8 = TextEncoding { textEncodingName = "UTF-8",
40 mkTextDecoder = utf8_DF,
41 mkTextEncoder = utf8_EF }
43 utf8_DF :: IO (TextDecoder ())
49 setState = const $ return ()
52 utf8_EF :: IO (TextEncoder ())
58 setState = const $ return ()
61 utf8_bom :: TextEncoding
62 utf8_bom = TextEncoding { textEncodingName = "UTF-8BOM",
63 mkTextDecoder = utf8_bom_DF,
64 mkTextEncoder = utf8_bom_EF }
66 utf8_bom_DF :: IO (TextDecoder Bool)
70 encode = utf8_bom_decode ref,
72 getState = readIORef ref,
73 setState = writeIORef ref
76 utf8_bom_EF :: IO (TextEncoder Bool)
80 encode = utf8_bom_encode ref,
82 getState = readIORef ref,
83 setState = writeIORef ref
86 utf8_bom_decode :: IORef Bool -> DecodeBuffer
88 input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ }
91 first <- readIORef ref
93 then utf8_decode input output
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
107 utf8_decode input{ bufL = ir + 3 } output
109 utf8_bom_encode :: IORef Bool -> EncodeBuffer
110 utf8_bom_encode ref input
111 output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os }
114 if not b then utf8_encode input output
116 then return (input,output)
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 }
124 bom0, bom1, bom2 :: Word8
129 utf8_decode :: DecodeBuffer
131 input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
132 output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
135 | ow >= os || ir >= iw = done ir ow
137 c0 <- readWord8Buf iraw ir
140 ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0))
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)
148 | c0 >= 0xe0 && c0 <= 0xef ->
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
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)
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
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
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)
185 invalid = if ir > ir0 then done ir ow else ioe_decodingError
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 },
194 ioe_decodingError :: IO a
195 ioe_decodingError = ioException
196 (IOError Nothing InvalidArgument "utf8_decode"
197 "invalid UTF-8 byte sequence" Nothing Nothing)
199 utf8_encode :: EncodeBuffer
201 input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
202 output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
204 done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
205 else input{ bufL=ir },
208 | ow >= os || ir >= iw = done ir ow
210 (c,ir') <- readCharBuf iraw ir
213 writeWord8Buf oraw ow (fromIntegral x)
216 if os - ow < 2 then done ir ow else do
218 writeWord8Buf oraw ow c1
219 writeWord8Buf oraw (ow+1) c2
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
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
239 -- -----------------------------------------------------------------------------
240 -- UTF-8 primitives, lifted from Data.Text.Fusion.Utf8
242 ord2 :: Char -> (Word8,Word8)
243 ord2 c = assert (n >= 0x80 && n <= 0x07ff) (x1,x2)
246 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
247 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
249 ord3 :: Char -> (Word8,Word8,Word8)
250 ord3 c = assert (n >= 0x0800 && n <= 0xffff) (x1,x2,x3)
253 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
254 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
255 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
257 ord4 :: Char -> (Word8,Word8,Word8,Word8)
258 ord4 c = assert (n >= 0x10000) (x1,x2,x3,x4)
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
266 chr2 :: Word8 -> Word8 -> Char
267 chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#))
271 !z1# = uncheckedIShiftL# (y1# -# 0xC0#) 6#
275 chr3 :: Word8 -> Word8 -> Word8 -> Char
276 chr3 (W8# x1#) (W8# x2#) (W8# x3#) = C# (chr# (z1# +# z2# +# z3#))
281 !z1# = uncheckedIShiftL# (y1# -# 0xE0#) 12#
282 !z2# = uncheckedIShiftL# (y2# -# 0x80#) 6#
286 chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char
287 chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) =
288 C# (chr# (z1# +# z2# +# z3# +# z4#))
294 !z1# = uncheckedIShiftL# (y1# -# 0xF0#) 18#
295 !z2# = uncheckedIShiftL# (y2# -# 0x80#) 12#
296 !z3# = uncheckedIShiftL# (y3# -# 0x80#) 6#
300 between :: Word8 -- ^ byte to check
301 -> Word8 -- ^ lower bound
302 -> Word8 -- ^ upper bound
304 between x y z = x >= y && x <= z
305 {-# INLINE between #-}
307 validate3 :: Word8 -> Word8 -> Word8 -> Bool
308 {-# INLINE validate3 #-}
309 validate3 x1 x2 x3 = validate3_1 ||
314 validate3_1 = (x1 == 0xE0) &&
315 between x2 0xA0 0xBF &&
317 validate3_2 = between x1 0xE1 0xEC &&
318 between x2 0x80 0xBF &&
320 validate3_3 = x1 == 0xED &&
321 between x2 0x80 0x9F &&
323 validate3_4 = between x1 0xEE 0xEF &&
324 between x2 0x80 0xBF &&
327 validate4 :: Word8 -> Word8 -> Word8 -> Word8 -> Bool
328 {-# INLINE validate4 #-}
329 validate4 x1 x2 x3 x4 = validate4_1 ||
333 validate4_1 = x1 == 0xF0 &&
334 between x2 0x90 0xBF &&
335 between x3 0x80 0xBF &&
337 validate4_2 = between x1 0xF1 0xF3 &&
338 between x2 0x80 0xBF &&
339 between x3 0x80 0xBF &&
341 validate4_3 = x1 == 0xF4 &&
342 between x2 0x80 0x8F &&
343 between x3 0x80 0xBF &&