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 ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral x1))
 199                          loop (ir+2) ow'
 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                       ow' <- writeCharBuf oraw ow (chr2 x1 x2)
 206                       loop (ir+4) ow'
 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 ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral x1))
 231                          loop (ir+2) ow'
 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                       ow' <- writeCharBuf oraw ow (chr2 x1 x2)
 238                       loop (ir+4) ow'
 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 #-}