content: {-# LANGUAGE Trustworthy #-}
  {-# LANGUAGE NoImplicitPrelude
             , BangPatterns
             , NondecreasingIndentation
             , MagicHash
    #-}
  {-# OPTIONS_GHC  -funbox-strict-fields #-}
  
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  GHC.IO.Encoding.UTF16
  -- Copyright   :  (c) The University of Glasgow, 2009
  -- License     :  see libraries/base/LICENSE
  --
  -- Maintainer  :  libraries@haskell.org
  -- Stability   :  internal
  -- Portability :  non-portable
  --
  -- UTF-16 Codecs for the IO library
  --
  -- Portions Copyright   : (c) Tom Harper 2008-2009,
  --                        (c) Bryan O'Sullivan 2009,
  --                        (c) Duncan Coutts 2009
  --
  -----------------------------------------------------------------------------
  
  module GHC.IO.Encoding.UTF16 (
    utf16, mkUTF16,
    utf16_decode,
    utf16_encode,
  
    utf16be, mkUTF16be,
    utf16be_decode,
    utf16be_encode,
  
    utf16le, mkUTF16le,
    utf16le_decode,
    utf16le_encode,
    ) where
  
  import GHC.Base
  import GHC.Real
  import GHC.Num
  -- import GHC.IO
  import GHC.IO.Buffer
  import GHC.IO.Encoding.Failure
  import GHC.IO.Encoding.Types
  import GHC.Word
  import Data.Bits
  import GHC.IORef
  
  -- -----------------------------------------------------------------------------
  -- The UTF-16 codec: either UTF16BE or UTF16LE with a BOM
  
  utf16  :: TextEncoding
  utf16 = mkUTF16 ErrorOnCodingFailure
  
  -- | @since 4.4.0.0
  mkUTF16 :: CodingFailureMode -> TextEncoding
  mkUTF16 cfm =  TextEncoding { textEncodingName = "UTF-16",
                                mkTextDecoder = utf16_DF cfm,
                                mkTextEncoder = utf16_EF cfm }
  
  utf16_DF :: CodingFailureMode -> IO (TextDecoder (Maybe DecodeBuffer))
  utf16_DF cfm = do
    seen_bom <- newIORef Nothing
    return (BufferCodec {
               encode   = utf16_decode seen_bom,
               recover  = recoverDecode cfm,
               close    = return (),
               getState = readIORef seen_bom,
               setState = writeIORef seen_bom
            })
  
  utf16_EF :: CodingFailureMode -> IO (TextEncoder Bool)
  utf16_EF cfm = do
    done_bom <- newIORef False
    return (BufferCodec {
               encode   = utf16_encode done_bom,
               recover  = recoverEncode cfm,
               close    = return (),
               getState = readIORef done_bom,
               setState = writeIORef done_bom
            })
  
  utf16_encode :: IORef Bool -> EncodeBuffer
  utf16_encode done_bom input
    output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os }
   = do
    b <- readIORef done_bom
    if b then utf16_native_encode input output
         else if os - ow < 2
                 then return (OutputUnderflow,input,output)
                 else do
                      writeIORef done_bom True
                      writeWord8Buf oraw ow     bom1
                      writeWord8Buf oraw (ow+1) bom2
                      utf16_native_encode input output{ bufR = ow+2 }
  
  utf16_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer
  utf16_decode seen_bom
    input@Buffer{  bufRaw=iraw, bufL=ir, bufR=iw,  bufSize=_  }
    output
   = do
     mb <- readIORef seen_bom
     case mb of
       Just decode -> decode input output
       Nothing ->
         if iw - ir < 2 then return (InputUnderflow,input,output) else do
         c0 <- readWord8Buf iraw ir
         c1 <- readWord8Buf iraw (ir+1)
         case () of
          _ | c0 == bomB && c1 == bomL -> do
                 writeIORef seen_bom (Just utf16be_decode)
                 utf16be_decode input{ bufL= ir+2 } output
            | c0 == bomL && c1 == bomB -> do
                 writeIORef seen_bom (Just utf16le_decode)
                 utf16le_decode input{ bufL= ir+2 } output
            | otherwise -> do
                 writeIORef seen_bom (Just utf16_native_decode)
                 utf16_native_decode input output
  
  
  bomB, bomL, bom1, bom2 :: Word8
  bomB = 0xfe
  bomL = 0xff
  
  -- choose UTF-16BE by default for UTF-16 output
  utf16_native_decode :: DecodeBuffer
  utf16_native_decode = utf16be_decode
  
  utf16_native_encode :: EncodeBuffer
  utf16_native_encode = utf16be_encode
  
  bom1 = bomB
  bom2 = bomL
  
  -- -----------------------------------------------------------------------------
  -- UTF16LE and UTF16BE
  
  utf16be :: TextEncoding
  utf16be = mkUTF16be ErrorOnCodingFailure
  
  -- | @since 4.4.0.0
  mkUTF16be :: CodingFailureMode -> TextEncoding
  mkUTF16be cfm = TextEncoding { textEncodingName = "UTF-16BE",
                                 mkTextDecoder = utf16be_DF cfm,
                                 mkTextEncoder = utf16be_EF cfm }
  
  utf16be_DF :: CodingFailureMode -> IO (TextDecoder ())
  utf16be_DF cfm =
    return (BufferCodec {
               encode   = utf16be_decode,
               recover  = recoverDecode cfm,
               close    = return (),
               getState = return (),
               setState = const $ return ()
            })
  
  utf16be_EF :: CodingFailureMode -> IO (TextEncoder ())
  utf16be_EF cfm =
    return (BufferCodec {
               encode   = utf16be_encode,
               recover  = recoverEncode cfm,
               close    = return (),
               getState = return (),
               setState = const $ return ()
            })
  
  utf16le :: TextEncoding
  utf16le = mkUTF16le ErrorOnCodingFailure
  
  -- | @since 4.4.0.0
  mkUTF16le :: CodingFailureMode -> TextEncoding
  mkUTF16le cfm = TextEncoding { textEncodingName = "UTF16-LE",
                                 mkTextDecoder = utf16le_DF cfm,
                                 mkTextEncoder = utf16le_EF cfm }
  
  utf16le_DF :: CodingFailureMode -> IO (TextDecoder ())
  utf16le_DF cfm =
    return (BufferCodec {
               encode   = utf16le_decode,
               recover  = recoverDecode cfm,
               close    = return (),
               getState = return (),
               setState = const $ return ()
            })
  
  utf16le_EF :: CodingFailureMode -> IO (TextEncoder ())
  utf16le_EF cfm =
    return (BufferCodec {
               encode   = utf16le_encode,
               recover  = recoverEncode cfm,
               close    = return (),
               getState = return (),
               setState = const $ return ()
            })
  
  
  utf16be_decode :: DecodeBuffer
  utf16be_decode
    input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
    output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
   = let
         loop !ir !ow
           | ow >= os     = done OutputUnderflow ir ow
           | ir >= iw     = done InputUnderflow ir ow
           | ir + 1 == iw = done InputUnderflow ir ow
           | otherwise = do
                c0 <- readWord8Buf iraw ir
                c1 <- readWord8Buf iraw (ir+1)
                let x1 = fromIntegral c0 `shiftL` 8 + fromIntegral c1
                if validate1 x1
                   then do ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral x1))
                           loop (ir+2) ow'
                   else if iw - ir < 4 then done InputUnderflow ir ow else do
                        c2 <- readWord8Buf iraw (ir+2)
                        c3 <- readWord8Buf iraw (ir+3)
                        let x2 = fromIntegral c2 `shiftL` 8 + fromIntegral c3
                        if not (validate2 x1 x2) then invalid else do
                        ow' <- writeCharBuf oraw ow (chr2 x1 x2)
                        loop (ir+4) ow'
           where
             invalid = done InvalidSequence ir ow
  
         -- lambda-lifted, to avoid thunks being built in the inner-loop:
         done why !ir !ow = return (why,
                                    if ir == iw then input{ bufL=0, bufR=0 }
                                                else input{ bufL=ir },
                                    output{ bufR=ow })
      in
      loop ir0 ow0
  
  utf16le_decode :: DecodeBuffer
  utf16le_decode
    input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
    output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
   = let
         loop !ir !ow
           | ow >= os     = done OutputUnderflow ir ow
           | ir >= iw     = done InputUnderflow ir ow
           | ir + 1 == iw = done InputUnderflow ir ow
           | otherwise = do
                c0 <- readWord8Buf iraw ir
                c1 <- readWord8Buf iraw (ir+1)
                let x1 = fromIntegral c1 `shiftL` 8 + fromIntegral c0
                if validate1 x1
                   then do ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral x1))
                           loop (ir+2) ow'
                   else if iw - ir < 4 then done InputUnderflow ir ow else do
                        c2 <- readWord8Buf iraw (ir+2)
                        c3 <- readWord8Buf iraw (ir+3)
                        let x2 = fromIntegral c3 `shiftL` 8 + fromIntegral c2
                        if not (validate2 x1 x2) then invalid else do
                        ow' <- writeCharBuf oraw ow (chr2 x1 x2)
                        loop (ir+4) ow'
           where
             invalid = done InvalidSequence ir ow
  
         -- lambda-lifted, to avoid thunks being built in the inner-loop:
         done why !ir !ow = return (why,
                                    if ir == iw then input{ bufL=0, bufR=0 }
                                                else input{ bufL=ir },
                                    output{ bufR=ow })
      in
      loop ir0 ow0
  
  utf16be_encode :: EncodeBuffer
  utf16be_encode
    input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
    output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
   = let
        done why !ir !ow = return (why,
                                   if ir == iw then input{ bufL=0, bufR=0 }
                                               else input{ bufL=ir },
                                   output{ bufR=ow })
        loop !ir !ow
          | ir >= iw     =  done InputUnderflow ir ow
          | os - ow < 2  =  done OutputUnderflow ir ow
          | otherwise = do
             (c,ir') <- readCharBuf iraw ir
             case ord c of
               x | x < 0x10000 -> if isSurrogate c then done InvalidSequence ir ow else do
                      writeWord8Buf oraw ow     (fromIntegral (x `shiftR` 8))
                      writeWord8Buf oraw (ow+1) (fromIntegral x)
                      loop ir' (ow+2)
                 | otherwise -> do
                      if os - ow < 4 then done OutputUnderflow ir ow else do
                      let
                           n1 = x - 0x10000
                           c1 = fromIntegral (n1 `shiftR` 18 + 0xD8)
                           c2 = fromIntegral (n1 `shiftR` 10)
                           n2 = n1 .&. 0x3FF
                           c3 = fromIntegral (n2 `shiftR` 8 + 0xDC)
                           c4 = fromIntegral n2
                      --
                      writeWord8Buf oraw ow     c1
                      writeWord8Buf oraw (ow+1) c2
                      writeWord8Buf oraw (ow+2) c3
                      writeWord8Buf oraw (ow+3) c4
                      loop ir' (ow+4)
      in
      loop ir0 ow0
  
  utf16le_encode :: EncodeBuffer
  utf16le_encode
    input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
    output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
   = let
        done why !ir !ow = return (why,
                                   if ir == iw then input{ bufL=0, bufR=0 }
                                               else input{ bufL=ir },
                                   output{ bufR=ow })
        loop !ir !ow
          | ir >= iw     =  done InputUnderflow ir ow
          | os - ow < 2  =  done OutputUnderflow ir ow
          | otherwise = do
             (c,ir') <- readCharBuf iraw ir
             case ord c of
               x | x < 0x10000 -> if isSurrogate c then done InvalidSequence ir ow else do
                      writeWord8Buf oraw ow     (fromIntegral x)
                      writeWord8Buf oraw (ow+1) (fromIntegral (x `shiftR` 8))
                      loop ir' (ow+2)
                 | otherwise ->
                      if os - ow < 4 then done OutputUnderflow ir ow else do
                      let
                           n1 = x - 0x10000
                           c1 = fromIntegral (n1 `shiftR` 18 + 0xD8)
                           c2 = fromIntegral (n1 `shiftR` 10)
                           n2 = n1 .&. 0x3FF
                           c3 = fromIntegral (n2 `shiftR` 8 + 0xDC)
                           c4 = fromIntegral n2
                      --
                      writeWord8Buf oraw ow     c2
                      writeWord8Buf oraw (ow+1) c1
                      writeWord8Buf oraw (ow+2) c4
                      writeWord8Buf oraw (ow+3) c3
                      loop ir' (ow+4)
      in
      loop ir0 ow0
  
  chr2 :: Word16 -> Word16 -> Char
  chr2 (W16# a#) (W16# b#) = C# (chr# (upper# +# lower# +# 0x10000#))
      where
        !x# = word2Int# a#
        !y# = word2Int# b#
        !upper# = uncheckedIShiftL# (x# -# 0xD800#) 10#
        !lower# = y# -# 0xDC00#
  {-# INLINE chr2 #-}
  
  validate1    :: Word16 -> Bool
  validate1 x1 = (x1 >= 0 && x1 < 0xD800) || x1 > 0xDFFF
  {-# INLINE validate1 #-}
  
  validate2       ::  Word16 -> Word16 -> Bool
  validate2 x1 x2 = x1 >= 0xD800 && x1 <= 0xDBFF &&
                    x2 >= 0xDC00 && x2 <= 0xDFFF
  {-# INLINE validate2 #-}
  
  