GHC/IO/Encoding/UTF8.hs

   1 {-# OPTIONS_GHC -fno-implicit-prelude -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_decode,
  24   utf8_encode,
  25   ) where
  26
  27 import GHC.Base
  28 import GHC.Real
  29 import GHC.Num
  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_decode :: DecodeBuffer
  61 utf8_decode
  62   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
  63   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
  64  = let
  65        loop !ir !ow
  66          | ow >= os || ir >= iw = done ir ow
  67          | otherwise = do
  68               c0 <- readWord8Buf iraw ir
  69               case c0 of
  70                 _ | c0 <= 0x7f -> do
  71                            writeCharBuf oraw ow (unsafeChr (fromIntegral c0))
  72                            loop (ir+1) (ow+1)
  73                   | c0 >= 0xc0 && c0 <= 0xdf ->
  74                            if iw - ir < 2 then done ir ow else do
  75                            c1 <- readWord8Buf iraw (ir+1)
  76                            if (c1 < 0x80 || c1 >= 0xc0) then invalid else do
  77                            writeCharBuf oraw ow (chr2 c0 c1)
  78                            loop (ir+2) (ow+1)
  79                   | c0 >= 0xe0 && c0 <= 0xef ->
  80                            if iw - ir < 3 then done ir ow else do
  81                            c1 <- readWord8Buf iraw (ir+1)
  82                            c2 <- readWord8Buf iraw (ir+2)
  83                            if not (validate3 c0 c1 c2) then invalid else do
  84                            writeCharBuf oraw ow (chr3 c0 c1 c2)
  85                            loop (ir+3) (ow+1)
  86                   | otherwise ->
  87                            if iw - ir < 4 then done ir ow else do
  88                            c1 <- readWord8Buf iraw (ir+1)
  89                            c2 <- readWord8Buf iraw (ir+2)
  90                            c3 <- readWord8Buf iraw (ir+3)
  91                            if not (validate4 c0 c1 c2 c3) then invalid else do
  92                            writeCharBuf oraw ow (chr4 c0 c1 c2 c3)
  93                            loop (ir+4) (ow+1)
  94          where
  95            invalid = if ir > ir0 then done ir ow else ioe_decodingError
  96
  97        -- lambda-lifted, to avoid thunks being built in the inner-loop:
  98        done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
  99                                           else input{ bufL=ir },
 100                          output{ bufR=ow })
 101    in
 102    loop ir0 ow0
 103
 104 ioe_decodingError :: IO a
 105 ioe_decodingError = ioException
 106      (IOError Nothing InvalidArgument "utf8_decode"
 107           "invalid UTF-8 byte sequence" Nothing Nothing)
 108
 109 utf8_encode :: EncodeBuffer
 110 utf8_encode
 111   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
 112   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
 113  = let
 114       done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
 115                                          else input{ bufL=ir },
 116                              output{ bufR=ow })
 117       loop !ir !ow
 118         | ow >= os || ir >= iw = done ir ow
 119         | otherwise = do
 120            (c,ir') <- readCharBuf iraw ir
 121            case ord c of
 122              x | x <= 0x7F   -> do
 123                     writeWord8Buf oraw ow (fromIntegral x)
 124                     loop ir' (ow+1)
 125                | x <= 0x07FF ->
 126                     if os - ow < 2 then done ir ow else do
 127                     let (c1,c2) = ord2 c
 128                     writeWord8Buf oraw ow     c1
 129                     writeWord8Buf oraw (ow+1) c2
 130                     loop ir' (ow+2)
 131                | x <= 0xFFFF -> do
 132                     if os - ow < 3 then done ir ow else do
 133                     let (c1,c2,c3) = ord3 c
 134                     writeWord8Buf oraw ow     c1
 135                     writeWord8Buf oraw (ow+1) c2
 136                     writeWord8Buf oraw (ow+2) c3
 137                     loop ir' (ow+3)
 138                | otherwise -> do
 139                     if os - ow < 4 then done ir ow else do
 140                     let (c1,c2,c3,c4) = ord4 c
 141                     writeWord8Buf oraw ow     c1
 142                     writeWord8Buf oraw (ow+1) c2
 143                     writeWord8Buf oraw (ow+2) c3
 144                     writeWord8Buf oraw (ow+3) c4
 145                     loop ir' (ow+4)
 146    in
 147    loop ir0 ow0
 148
 149 -- -----------------------------------------------------------------------------
 150 -- UTF-8 primitives, lifted from Data.Text.Fusion.Utf8
 151
 152 ord2   :: Char -> (Word8,Word8)
 153 ord2 c = assert (n >= 0x80 && n <= 0x07ff) (x1,x2)
 154     where
 155       n  = ord c
 156       x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
 157       x2 = fromIntegral $ (n .&. 0x3F)   + 0x80
 158
 159 ord3   :: Char -> (Word8,Word8,Word8)
 160 ord3 c = assert (n >= 0x0800 && n <= 0xffff) (x1,x2,x3)
 161     where
 162       n  = ord c
 163       x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
 164       x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
 165       x3 = fromIntegral $ (n .&. 0x3F) + 0x80
 166
 167 ord4   :: Char -> (Word8,Word8,Word8,Word8)
 168 ord4 c = assert (n >= 0x10000) (x1,x2,x3,x4)
 169     where
 170       n  = ord c
 171       x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
 172       x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
 173       x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
 174       x4 = fromIntegral $ (n .&. 0x3F) + 0x80
 175
 176 chr2       :: Word8 -> Word8 -> Char
 177 chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#))
 178     where
 179       !y1# = word2Int# x1#
 180       !y2# = word2Int# x2#
 181       !z1# = uncheckedIShiftL# (y1# -# 0xC0#) 6#
 182       !z2# = y2# -# 0x80#
 183 {-# INLINE chr2 #-}
 184
 185 chr3          :: Word8 -> Word8 -> Word8 -> Char
 186 chr3 (W8# x1#) (W8# x2#) (W8# x3#) = C# (chr# (z1# +# z2# +# z3#))
 187     where
 188       !y1# = word2Int# x1#
 189       !y2# = word2Int# x2#
 190       !y3# = word2Int# x3#
 191       !z1# = uncheckedIShiftL# (y1# -# 0xE0#) 12#
 192       !z2# = uncheckedIShiftL# (y2# -# 0x80#) 6#
 193       !z3# = y3# -# 0x80#
 194 {-# INLINE chr3 #-}
 195
 196 chr4             :: Word8 -> Word8 -> Word8 -> Word8 -> Char
 197 chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) =
 198     C# (chr# (z1# +# z2# +# z3# +# z4#))
 199     where
 200       !y1# = word2Int# x1#
 201       !y2# = word2Int# x2#
 202       !y3# = word2Int# x3#
 203       !y4# = word2Int# x4#
 204       !z1# = uncheckedIShiftL# (y1# -# 0xF0#) 18#
 205       !z2# = uncheckedIShiftL# (y2# -# 0x80#) 12#
 206       !z3# = uncheckedIShiftL# (y3# -# 0x80#) 6#
 207       !z4# = y4# -# 0x80#
 208 {-# INLINE chr4 #-}
 209
 210 between :: Word8                -- ^ byte to check
 211         -> Word8                -- ^ lower bound
 212         -> Word8                -- ^ upper bound
 213         -> Bool
 214 between x y z = x >= y && x <= z
 215 {-# INLINE between #-}
 216
 217 validate3          :: Word8 -> Word8 -> Word8 -> Bool
 218 {-# INLINE validate3 #-}
 219 validate3 x1 x2 x3 = validate3_1 ||
 220                      validate3_2 ||
 221                      validate3_3 ||
 222                      validate3_4
 223   where
 224     validate3_1 = (x1 == 0xE0) &&
 225                   between x2 0xA0 0xBF &&
 226                   between x3 0x80 0xBF
 227     validate3_2 = between x1 0xE1 0xEC &&
 228                   between x2 0x80 0xBF &&
 229                   between x3 0x80 0xBF
 230     validate3_3 = x1 == 0xED &&
 231                   between x2 0x80 0x9F &&
 232                   between x3 0x80 0xBF
 233     validate3_4 = between x1 0xEE 0xEF &&
 234                   between x2 0x80 0xBF &&
 235                   between x3 0x80 0xBF
 236
 237 validate4             :: Word8 -> Word8 -> Word8 -> Word8 -> Bool
 238 {-# INLINE validate4 #-}
 239 validate4 x1 x2 x3 x4 = validate4_1 ||
 240                         validate4_2 ||
 241                         validate4_3
 242   where
 243     validate4_1 = x1 == 0xF0 &&
 244                   between x2 0x90 0xBF &&
 245                   between x3 0x80 0xBF &&
 246                   between x4 0x80 0xBF
 247     validate4_2 = between x1 0xF1 0xF3 &&
 248                   between x2 0x80 0xBF &&
 249                   between x3 0x80 0xBF &&
 250                   between x4 0x80 0xBF
 251     validate4_3 = x1 == 0xF4 &&
 252                   between x2 0x80 0x8F &&
 253                   between x3 0x80 0xBF &&
 254                   between x4 0x80 0xBF