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