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