GHC/IO/Encoding/UTF16.hs

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