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