GHC/IO/Encoding/UTF16.hs

   1 {-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
   2 {-# LANGUAGE BangPatterns #-}
   3 -----------------------------------------------------------------------------
   4 -- |
   5 -- Module      :  GHC.IO.Encoding.UTF16
   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-16 Codecs 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.UTF16 (
  22   utf16,
  23   utf16_decode,
  24   utf16_encode,
  25
  26   utf16be,
  27   utf16be_decode,
  28   utf16be_encode,
  29
  30   utf16le,
  31   utf16le_decode,
  32   utf16le_encode,
  33   ) where
  34
  35 import GHC.Base
  36 import GHC.Real
  37 import GHC.Num
  38 import GHC.IO
  39 import GHC.IO.Exception
  40 import GHC.IO.Buffer
  41 import GHC.IO.Encoding.Types
  42 import GHC.Word
  43 import Data.Bits
  44 import Data.Maybe
  45 import GHC.IORef
  46
  47 #if DEBUG
  48 import System.Posix.Internals
  49 import Foreign.C
  50 import GHC.Show
  51
  52 puts :: String -> IO ()
  53 puts s = do withCStringLen (s++"\n") $ \(p,len) ->
  54                 c_write 1 p (fromIntegral len)
  55             return ()
  56 #endif
  57
  58 -- -----------------------------------------------------------------------------
  59 -- The UTF-16 codec: either UTF16BE or UTF16LE with a BOM
  60
  61 utf16  :: TextEncoding
  62 utf16 = TextEncoding { mkTextDecoder = utf16_DF,
  63                        mkTextEncoder = utf16_EF }
  64
  65 utf16_DF :: IO (TextDecoder (Maybe DecodeBuffer))
  66 utf16_DF = do
  67   seen_bom <- newIORef Nothing
  68   return (BufferCodec {
  69              encode   = utf16_decode seen_bom,
  70              close    = return (),
  71              getState = readIORef seen_bom,
  72              setState = writeIORef seen_bom
  73           })
  74
  75 utf16_EF :: IO (TextEncoder Bool)
  76 utf16_EF = do
  77   done_bom <- newIORef False
  78   return (BufferCodec {
  79              encode   = utf16_encode done_bom,
  80              close    = return (),
  81              getState = readIORef done_bom,
  82              setState = writeIORef done_bom
  83           })
  84
  85 utf16_encode :: IORef Bool -> EncodeBuffer
  86 utf16_encode done_bom input
  87   output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os }
  88  = do
  89   b <- readIORef done_bom
  90   if b then utf16_native_encode input output
  91        else if os - ow < 2
  92                then return (input,output)
  93                else do
  94                     writeIORef done_bom True
  95                     writeWord8Buf oraw ow     bom1
  96                     writeWord8Buf oraw (ow+1) bom2
  97                     utf16_native_encode input output{ bufR = ow+2 }
  98
  99 utf16_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer
 100 utf16_decode seen_bom
 101   input@Buffer{  bufRaw=iraw, bufL=ir, bufR=iw,  bufSize=_  }
 102   output
 103  = do
 104    mb <- readIORef seen_bom
 105    case mb of
 106      Just decode -> decode input output
 107      Nothing ->
 108        if iw - ir < 2 then return (input,output) else do
 109        c0 <- readWord8Buf iraw ir
 110        c1 <- readWord8Buf iraw (ir+1)
 111        case () of
 112         _ | c0 == bomB && c1 == bomL -> do
 113                writeIORef seen_bom (Just utf16be_decode)
 114                utf16be_decode input{ bufL= ir+2 } output
 115           | c0 == bomL && c1 == bomB -> do
 116                writeIORef seen_bom (Just utf16le_decode)
 117                utf16le_decode input{ bufL= ir+2 } output
 118           | otherwise -> do
 119                writeIORef seen_bom (Just utf16_native_decode)
 120                utf16_native_decode input output
 121
 122
 123 bomB, bomL, bom1, bom2 :: Word8
 124 bomB = 0xfe
 125 bomL = 0xff
 126
 127 -- choose UTF-16BE by default for UTF-16 output
 128 utf16_native_decode :: DecodeBuffer
 129 utf16_native_decode = utf16be_decode
 130
 131 utf16_native_encode :: EncodeBuffer
 132 utf16_native_encode = utf16be_encode
 133
 134 bom1 = bomB
 135 bom2 = bomL
 136
 137 -- -----------------------------------------------------------------------------
 138 -- UTF16LE and UTF16BE
 139
 140 utf16be :: TextEncoding
 141 utf16be = TextEncoding { mkTextDecoder = utf16be_DF,
 142                          mkTextEncoder = utf16be_EF }
 143
 144 utf16be_DF :: IO (TextDecoder ())
 145 utf16be_DF =
 146   return (BufferCodec {
 147              encode   = utf16be_decode,
 148              close    = return (),
 149              getState = return (),
 150              setState = const $ return ()
 151           })
 152
 153 utf16be_EF :: IO (TextEncoder ())
 154 utf16be_EF =
 155   return (BufferCodec {
 156              encode   = utf16be_encode,
 157              close    = return (),
 158              getState = return (),
 159              setState = const $ return ()
 160           })
 161
 162 utf16le :: TextEncoding
 163 utf16le = TextEncoding { mkTextDecoder = utf16le_DF,
 164                          mkTextEncoder = utf16le_EF }
 165
 166 utf16le_DF :: IO (TextDecoder ())
 167 utf16le_DF =
 168   return (BufferCodec {
 169              encode   = utf16le_decode,
 170              close    = return (),
 171              getState = return (),
 172              setState = const $ return ()
 173           })
 174
 175 utf16le_EF :: IO (TextEncoder ())
 176 utf16le_EF =
 177   return (BufferCodec {
 178              encode   = utf16le_encode,
 179              close    = return (),
 180              getState = return (),
 181              setState = const $ return ()
 182           })
 183
 184
 185 utf16be_decode :: DecodeBuffer
 186 utf16be_decode
 187   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
 188   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
 189  = let
 190        loop !ir !ow
 191          | ow >= os || ir >= iw  =  done ir ow
 192          | ir + 1 == iw          =  done ir ow
 193          | otherwise = do
 194               c0 <- readWord8Buf iraw ir
 195               c1 <- readWord8Buf iraw (ir+1)
 196               let x1 = fromIntegral c0 `shiftL` 8 + fromIntegral c1
 197               if validate1 x1
 198                  then do writeCharBuf oraw ow (unsafeChr (fromIntegral x1))
 199                          loop (ir+2) (ow+1)
 200                  else if iw - ir < 4 then done ir ow else do
 201                       c2 <- readWord8Buf iraw (ir+2)
 202                       c3 <- readWord8Buf iraw (ir+3)
 203                       let x2 = fromIntegral c2 `shiftL` 8 + fromIntegral c3
 204                       if not (validate2 x1 x2) then invalid else do
 205                       writeCharBuf oraw ow (chr2 x1 x2)
 206                       loop (ir+4) (ow+1)
 207          where
 208            invalid = if ir > ir0 then done ir ow else ioe_decodingError
 209
 210        -- lambda-lifted, to avoid thunks being built in the inner-loop:
 211        done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
 212                                           else input{ bufL=ir },
 213                          output{ bufR=ow })
 214     in
 215     loop ir0 ow0
 216
 217 utf16le_decode :: DecodeBuffer
 218 utf16le_decode
 219   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
 220   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
 221  = let
 222        loop !ir !ow
 223          | ow >= os || ir >= iw  =  done ir ow
 224          | ir + 1 == iw          =  done ir ow
 225          | otherwise = do
 226               c0 <- readWord8Buf iraw ir
 227               c1 <- readWord8Buf iraw (ir+1)
 228               let x1 = fromIntegral c1 `shiftL` 8 + fromIntegral c0
 229               if validate1 x1
 230                  then do writeCharBuf oraw ow (unsafeChr (fromIntegral x1))
 231                          loop (ir+2) (ow+1)
 232                  else if iw - ir < 4 then done ir ow else do
 233                       c2 <- readWord8Buf iraw (ir+2)
 234                       c3 <- readWord8Buf iraw (ir+3)
 235                       let x2 = fromIntegral c3 `shiftL` 8 + fromIntegral c2
 236                       if not (validate2 x1 x2) then invalid else do
 237                       writeCharBuf oraw ow (chr2 x1 x2)
 238                       loop (ir+4) (ow+1)
 239          where
 240            invalid = if ir > ir0 then done ir ow else ioe_decodingError
 241
 242        -- lambda-lifted, to avoid thunks being built in the inner-loop:
 243        done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
 244                                           else input{ bufL=ir },
 245                          output{ bufR=ow })
 246     in
 247     loop ir0 ow0
 248
 249 ioe_decodingError :: IO a
 250 ioe_decodingError = ioException
 251      (IOError Nothing InvalidArgument "utf16_decode"
 252           "invalid UTF-16 byte sequence" Nothing Nothing)
 253
 254 utf16be_encode :: EncodeBuffer
 255 utf16be_encode
 256   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
 257   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
 258  = let
 259       done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
 260                                          else input{ bufL=ir },
 261                              output{ bufR=ow })
 262       loop !ir !ow
 263         | ir >= iw     =  done ir ow
 264         | os - ow < 2  =  done ir ow
 265         | otherwise = do
 266            (c,ir') <- readCharBuf iraw ir
 267            case ord c of
 268              x | x < 0x10000 -> do
 269                     writeWord8Buf oraw ow     (fromIntegral (x `shiftR` 8))
 270                     writeWord8Buf oraw (ow+1) (fromIntegral x)
 271                     loop ir' (ow+2)
 272                | otherwise -> do
 273                     if os - ow < 4 then done ir ow else do
 274                     let
 275                          n1 = x - 0x10000
 276                          c1 = fromIntegral (n1 `shiftR` 18 + 0xD8)
 277                          c2 = fromIntegral (n1 `shiftR` 10)
 278                          n2 = n1 .&. 0x3FF
 279                          c3 = fromIntegral (n2 `shiftR` 8 + 0xDC)
 280                          c4 = fromIntegral n2
 281                     --
 282                     writeWord8Buf oraw ow     c1
 283                     writeWord8Buf oraw (ow+1) c2
 284                     writeWord8Buf oraw (ow+2) c3
 285                     writeWord8Buf oraw (ow+3) c4
 286                     loop ir' (ow+4)
 287     in
 288     loop ir0 ow0
 289
 290 utf16le_encode :: EncodeBuffer
 291 utf16le_encode
 292   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
 293   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
 294  = let
 295       done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
 296                                          else input{ bufL=ir },
 297                              output{ bufR=ow })
 298       loop !ir !ow
 299         | ir >= iw     =  done ir ow
 300         | os - ow < 2  =  done ir ow
 301         | otherwise = do
 302            (c,ir') <- readCharBuf iraw ir
 303            case ord c of
 304              x | x < 0x10000 -> do
 305                     writeWord8Buf oraw ow     (fromIntegral x)
 306                     writeWord8Buf oraw (ow+1) (fromIntegral (x `shiftR` 8))
 307                     loop ir' (ow+2)
 308                | otherwise ->
 309                     if os - ow < 4 then done ir ow else do
 310                     let
 311                          n1 = x - 0x10000
 312                          c1 = fromIntegral (n1 `shiftR` 18 + 0xD8)
 313                          c2 = fromIntegral (n1 `shiftR` 10)
 314                          n2 = n1 .&. 0x3FF
 315                          c3 = fromIntegral (n2 `shiftR` 8 + 0xDC)
 316                          c4 = fromIntegral n2
 317                     --
 318                     writeWord8Buf oraw ow     c2
 319                     writeWord8Buf oraw (ow+1) c1
 320                     writeWord8Buf oraw (ow+2) c4
 321                     writeWord8Buf oraw (ow+3) c3
 322                     loop ir' (ow+4)
 323     in
 324     loop ir0 ow0
 325
 326 chr2 :: Word16 -> Word16 -> Char
 327 chr2 (W16# a#) (W16# b#) = C# (chr# (upper# +# lower# +# 0x10000#))
 328     where
 329       !x# = word2Int# a#
 330       !y# = word2Int# b#
 331       !upper# = uncheckedIShiftL# (x# -# 0xD800#) 10#
 332       !lower# = y# -# 0xDC00#
 333 {-# INLINE chr2 #-}
 334
 335 validate1    :: Word16 -> Bool
 336 validate1 x1 = (x1 >= 0 && x1 < 0xD800) || x1 > 0xDFFF
 337 {-# INLINE validate1 #-}
 338
 339 validate2       ::  Word16 -> Word16 -> Bool
 340 validate2 x1 x2 = x1 >= 0xD800 && x1 <= 0xDBFF &&
 341                   x2 >= 0xDC00 && x2 <= 0xDFFF
 342 {-# INLINE validate2 #-}