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