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