GHC/IO/Encoding/UTF16.hs

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