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