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