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