{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude
           , BangPatterns
           , NondecreasingIndentation
           , MagicHash
  #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.IO.Encoding.UTF8
-- Copyright   :  (c) The University of Glasgow, 2009
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable
--
-- UTF-8 Codec for the IO library
--
-- Portions Copyright   : (c) Tom Harper 2008-2009,
--                        (c) Bryan O'Sullivan 2009,
--                        (c) Duncan Coutts 2009
--
-----------------------------------------------------------------------------

module GHC.IO.Encoding.UTF8 (
  utf8, mkUTF8,
  utf8_bom, mkUTF8_bom
  ) where

import GHC.Base
import GHC.Real
import GHC.Num
import GHC.IORef
-- import GHC.IO
import GHC.IO.Buffer
import GHC.IO.Encoding.Failure
import GHC.IO.Encoding.Types
import GHC.Word
import Data.Bits

utf8 :: TextEncoding
utf8 = mkUTF8 ErrorOnCodingFailure

-- | @since 4.4.0.0
mkUTF8 :: CodingFailureMode -> TextEncoding
mkUTF8 cfm = TextEncoding { textEncodingName = "UTF-8",
                            mkTextDecoder = utf8_DF cfm,
                            mkTextEncoder = utf8_EF cfm }

utf8_DF :: CodingFailureMode -> IO (TextDecoder ())
utf8_DF cfm =
  return (BufferCodec {
             encode   = utf8_decode,
             recover  = recoverDecode cfm,
             close    = return (),
             getState = return (),
             setState = const $ return ()
          })

utf8_EF :: CodingFailureMode -> IO (TextEncoder ())
utf8_EF cfm =
  return (BufferCodec {
             encode   = utf8_encode,
             recover  = recoverEncode cfm,
             close    = return (),
             getState = return (),
             setState = const $ return ()
          })

utf8_bom :: TextEncoding
utf8_bom = mkUTF8_bom ErrorOnCodingFailure

mkUTF8_bom :: CodingFailureMode -> TextEncoding
mkUTF8_bom cfm = TextEncoding { textEncodingName = "UTF-8BOM",
                                mkTextDecoder = utf8_bom_DF cfm,
                                mkTextEncoder = utf8_bom_EF cfm }

utf8_bom_DF :: CodingFailureMode -> IO (TextDecoder Bool)
utf8_bom_DF cfm = do
   ref <- newIORef True
   return (BufferCodec {
             encode   = utf8_bom_decode ref,
             recover  = recoverDecode cfm,
             close    = return (),
             getState = readIORef ref,
             setState = writeIORef ref
          })

utf8_bom_EF :: CodingFailureMode -> IO (TextEncoder Bool)
utf8_bom_EF cfm = do
   ref <- newIORef True
   return (BufferCodec {
             encode   = utf8_bom_encode ref,
             recover  = recoverEncode cfm,
             close    = return (),
             getState = readIORef ref,
             setState = writeIORef ref
          })

utf8_bom_decode :: IORef Bool -> DecodeBuffer
utf8_bom_decode ref
  input@Buffer{  bufRaw=iraw, bufL=ir, bufR=iw,  bufSize=_  }
  output
 = do
   first <- readIORef ref
   if not first
      then utf8_decode input output
      else do
       let no_bom = do writeIORef ref False; utf8_decode input output
       if iw - ir < 1 then return (InputUnderflow,input,output) else do
       c0 <- readWord8Buf iraw ir
       if (c0 /= bom0) then no_bom else do
       if iw - ir < 2 then return (InputUnderflow,input,output) else do
       c1 <- readWord8Buf iraw (ir+1)
       if (c1 /= bom1) then no_bom else do
       if iw - ir < 3 then return (InputUnderflow,input,output) else do
       c2 <- readWord8Buf iraw (ir+2)
       if (c2 /= bom2) then no_bom else do
       -- found a BOM, ignore it and carry on
       writeIORef ref False
       utf8_decode input{ bufL = ir + 3 } output

utf8_bom_encode :: IORef Bool -> EncodeBuffer
utf8_bom_encode ref input
  output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os }
 = do
  b <- readIORef ref
  if not b then utf8_encode input output
           else if os - ow < 3
                  then return (OutputUnderflow,input,output)
                  else do
                    writeIORef ref False
                    writeWord8Buf oraw ow     bom0
                    writeWord8Buf oraw (ow+1) bom1
                    writeWord8Buf oraw (ow+2) bom2
                    utf8_encode input output{ bufR = ow+3 }

bom0, bom1, bom2 :: Word8
bom0 = 0xef
bom1 = 0xbb
bom2 = 0xbf

utf8_decode :: DecodeBuffer
utf8_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
         | otherwise = do
              c0 <- readWord8Buf iraw ir
              case c0 of
                _ | c0 <= 0x7f -> do
                           ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0))
                           loop (ir+1) ow'
                  | c0 >= 0xc0 && c0 <= 0xc1 -> invalid -- Overlong forms
                  | c0 >= 0xc2 && c0 <= 0xdf ->
                           if iw - ir < 2 then done InputUnderflow ir ow else do
                           c1 <- readWord8Buf iraw (ir+1)
                           if (c1 < 0x80 || c1 >= 0xc0) then invalid else do
                           ow' <- writeCharBuf oraw ow (chr2 c0 c1)
                           loop (ir+2) ow'
                  | c0 >= 0xe0 && c0 <= 0xef ->
                      case iw - ir of
                        1 -> done InputUnderflow ir ow
                        2 -> do -- check for an error even when we don't have
                                -- the full sequence yet (#3341)
                           c1 <- readWord8Buf iraw (ir+1)
                           if not (validate3 c0 c1 0x80)
                              then invalid else done InputUnderflow ir ow
                        _ -> do
                           c1 <- readWord8Buf iraw (ir+1)
                           c2 <- readWord8Buf iraw (ir+2)
                           if not (validate3 c0 c1 c2) then invalid else do
                           ow' <- writeCharBuf oraw ow (chr3 c0 c1 c2)
                           loop (ir+3) ow'
                  | c0 >= 0xf0 ->
                      case iw - ir of
                        1 -> done InputUnderflow ir ow
                        2 -> do -- check for an error even when we don't have
                                -- the full sequence yet (#3341)
                           c1 <- readWord8Buf iraw (ir+1)
                           if not (validate4 c0 c1 0x80 0x80)
                              then invalid else done InputUnderflow ir ow
                        3 -> do
                           c1 <- readWord8Buf iraw (ir+1)
                           c2 <- readWord8Buf iraw (ir+2)
                           if not (validate4 c0 c1 c2 0x80)
                              then invalid else done InputUnderflow ir ow
                        _ -> do
                           c1 <- readWord8Buf iraw (ir+1)
                           c2 <- readWord8Buf iraw (ir+2)
                           c3 <- readWord8Buf iraw (ir+3)
                           if not (validate4 c0 c1 c2 c3) then invalid else do
                           ow' <- writeCharBuf oraw ow (chr4 c0 c1 c2 c3)
                           loop (ir+4) ow'
                  | otherwise ->
                           invalid
         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

utf8_encode :: EncodeBuffer
utf8_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
        | ow >= os = done OutputUnderflow ir ow
        | ir >= iw = done InputUnderflow ir ow
        | otherwise = do
           (c,ir') <- readCharBuf iraw ir
           case ord c of
             x | x <= 0x7F   -> do
                    writeWord8Buf oraw ow (fromIntegral x)
                    loop ir' (ow+1)
               | x <= 0x07FF ->
                    if os - ow < 2 then done OutputUnderflow ir ow else do
                    let (c1,c2) = ord2 c
                    writeWord8Buf oraw ow     c1
                    writeWord8Buf oraw (ow+1) c2
                    loop ir' (ow+2)
               | x <= 0xFFFF -> if isSurrogate c then done InvalidSequence ir ow else do
                    if os - ow < 3 then done OutputUnderflow ir ow else do
                    let (c1,c2,c3) = ord3 c
                    writeWord8Buf oraw ow     c1
                    writeWord8Buf oraw (ow+1) c2
                    writeWord8Buf oraw (ow+2) c3
                    loop ir' (ow+3)
               | otherwise -> do
                    if os - ow < 4 then done OutputUnderflow ir ow else do
                    let (c1,c2,c3,c4) = ord4 c
                    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

-- -----------------------------------------------------------------------------
-- UTF-8 primitives, lifted from Data.Text.Fusion.Utf8

ord2   :: Char -> (Word8,Word8)
ord2 c = assert (n >= 0x80 && n <= 0x07ff) (x1,x2)
    where
      n  = ord c
      x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
      x2 = fromIntegral $ (n .&. 0x3F)   + 0x80

ord3   :: Char -> (Word8,Word8,Word8)
ord3 c = assert (n >= 0x0800 && n <= 0xffff) (x1,x2,x3)
    where
      n  = ord c
      x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
      x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
      x3 = fromIntegral $ (n .&. 0x3F) + 0x80

ord4   :: Char -> (Word8,Word8,Word8,Word8)
ord4 c = assert (n >= 0x10000) (x1,x2,x3,x4)
    where
      n  = ord c
      x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
      x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
      x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
      x4 = fromIntegral $ (n .&. 0x3F) + 0x80

chr2       :: Word8 -> Word8 -> Char
chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#))
    where
      !y1# = word2Int# x1#
      !y2# = word2Int# x2#
      !z1# = uncheckedIShiftL# (y1# -# 0xC0#) 6#
      !z2# = y2# -# 0x80#
{-# INLINE chr2 #-}

chr3          :: Word8 -> Word8 -> Word8 -> Char
chr3 (W8# x1#) (W8# x2#) (W8# x3#) = C# (chr# (z1# +# z2# +# z3#))
    where
      !y1# = word2Int# x1#
      !y2# = word2Int# x2#
      !y3# = word2Int# x3#
      !z1# = uncheckedIShiftL# (y1# -# 0xE0#) 12#
      !z2# = uncheckedIShiftL# (y2# -# 0x80#) 6#
      !z3# = y3# -# 0x80#
{-# INLINE chr3 #-}

chr4             :: Word8 -> Word8 -> Word8 -> Word8 -> Char
chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) =
    C# (chr# (z1# +# z2# +# z3# +# z4#))
    where
      !y1# = word2Int# x1#
      !y2# = word2Int# x2#
      !y3# = word2Int# x3#
      !y4# = word2Int# x4#
      !z1# = uncheckedIShiftL# (y1# -# 0xF0#) 18#
      !z2# = uncheckedIShiftL# (y2# -# 0x80#) 12#
      !z3# = uncheckedIShiftL# (y3# -# 0x80#) 6#
      !z4# = y4# -# 0x80#
{-# INLINE chr4 #-}

between :: Word8                -- ^ byte to check
        -> Word8                -- ^ lower bound
        -> Word8                -- ^ upper bound
        -> Bool
between x y z = x >= y && x <= z
{-# INLINE between #-}

validate3          :: Word8 -> Word8 -> Word8 -> Bool
{-# INLINE validate3 #-}
validate3 x1 x2 x3 = validate3_1 ||
                     validate3_2 ||
                     validate3_3 ||
                     validate3_4
  where
    validate3_1 = (x1 == 0xE0) &&
                  between x2 0xA0 0xBF &&
                  between x3 0x80 0xBF
    validate3_2 = between x1 0xE1 0xEC &&
                  between x2 0x80 0xBF &&
                  between x3 0x80 0xBF
    validate3_3 = x1 == 0xED &&
                  between x2 0x80 0x9F &&
                  between x3 0x80 0xBF
    validate3_4 = between x1 0xEE 0xEF &&
                  between x2 0x80 0xBF &&
                  between x3 0x80 0xBF

validate4             :: Word8 -> Word8 -> Word8 -> Word8 -> Bool
{-# INLINE validate4 #-}
validate4 x1 x2 x3 x4 = validate4_1 ||
                        validate4_2 ||
                        validate4_3
  where
    validate4_1 = x1 == 0xF0 &&
                  between x2 0x90 0xBF &&
                  between x3 0x80 0xBF &&
                  between x4 0x80 0xBF
    validate4_2 = between x1 0xF1 0xF3 &&
                  between x2 0x80 0xBF &&
                  between x3 0x80 0xBF &&
                  between x4 0x80 0xBF
    validate4_3 = x1 == 0xF4 &&
                  between x2 0x80 0x8F &&
                  between x3 0x80 0xBF &&
                  between x4 0x80 0xBF


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, NondecreasingIndentation,
             RecordWildCards, ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

module GHC.IO.Encoding.CodePage.API (
    mkCodePageEncoding
  ) where

import Foreign.C
import Foreign.Ptr
import Foreign.Marshal
import Foreign.Storable
import Data.Bits
import Data.Either
import Data.Word

import GHC.Base
import GHC.List
import GHC.IO.Buffer
import GHC.IO.Encoding.Failure
import GHC.IO.Encoding.Types
import GHC.IO.Encoding.UTF16
import GHC.Num
import GHC.Show
import GHC.Real
import GHC.Windows
import GHC.ForeignPtr (castForeignPtr)

import System.Posix.Internals

c_DEBUG_DUMP :: Bool
c_DEBUG_DUMP = False

debugIO :: String -> IO ()
debugIO s
 | c_DEBUG_DUMP = puts s
 | otherwise    = return ()

#if defined(i386_HOST_ARCH)
# define WINDOWS_CCONV stdcall
#elif defined(x86_64_HOST_ARCH)
# define WINDOWS_CCONV ccall
#else
# error Unknown mingw32 arch
#endif

type LPCSTR = Ptr Word8

mAX_DEFAULTCHAR :: Int
mAX_DEFAULTCHAR = 2

mAX_LEADBYTES :: Int
mAX_LEADBYTES = 12

-- Don't really care about the contents of this, but we have to make sure the size is right
data CPINFO = CPINFO {
    maxCharSize :: UINT,
    defaultChar :: [BYTE], -- ^ Always of length mAX_DEFAULTCHAR
    leadByte    :: [BYTE]  -- ^ Always of length mAX_LEADBYTES
  }

-- | @since 4.7.0.0
instance Storable CPINFO where
    sizeOf    _ = sizeOf (undefined :: UINT) + (mAX_DEFAULTCHAR + mAX_LEADBYTES) * sizeOf (undefined :: BYTE)
    alignment _ = alignment (undefined :: CInt)
    peek ptr = do
      ptr <- return $ castPtr ptr
      a <- peek ptr
      ptr <- return $ castPtr $ advancePtr ptr 1
      b <- peekArray mAX_DEFAULTCHAR ptr
      c <- peekArray mAX_LEADBYTES   (advancePtr ptr mAX_DEFAULTCHAR)
      return $ CPINFO a b c
    poke ptr val = do
      ptr <- return $ castPtr ptr
      poke ptr (maxCharSize val)
      ptr <- return $ castPtr $ advancePtr ptr 1
      pokeArray' "CPINFO.defaultChar" mAX_DEFAULTCHAR ptr                              (defaultChar val)
      pokeArray' "CPINFO.leadByte"    mAX_LEADBYTES   (advancePtr ptr mAX_DEFAULTCHAR) (leadByte val)

pokeArray' :: Storable a => String -> Int -> Ptr a -> [a] -> IO ()
pokeArray' msg sz ptr xs | length xs == sz = pokeArray ptr xs
                         | otherwise       = errorWithoutStackTrace $ msg ++ ": expected " ++ show sz ++ " elements in list but got " ++ show (length xs)

foreign import WINDOWS_CCONV unsafe "windows.h GetCPInfo"
    c_GetCPInfo :: UINT       -- ^ CodePage
                -> Ptr CPINFO -- ^ lpCPInfo
                -> IO BOOL

foreign import WINDOWS_CCONV unsafe "windows.h MultiByteToWideChar"
    c_MultiByteToWideChar :: UINT   -- ^ CodePage
                          -> DWORD  -- ^ dwFlags
                          -> LPCSTR -- ^ lpMultiByteStr
                          -> CInt   -- ^ cbMultiByte
                          -> LPWSTR -- ^ lpWideCharStr
                          -> CInt   -- ^ cchWideChar
                          -> IO CInt

foreign import WINDOWS_CCONV unsafe "windows.h WideCharToMultiByte"
    c_WideCharToMultiByte :: UINT   -- ^ CodePage
                          -> DWORD  -- ^ dwFlags
                          -> LPWSTR -- ^ lpWideCharStr
                          -> CInt   -- ^ cchWideChar
                          -> LPCSTR -- ^ lpMultiByteStr
                          -> CInt   -- ^ cbMultiByte
                          -> LPCSTR -- ^ lpDefaultChar
                          -> LPBOOL -- ^ lpUsedDefaultChar
                          -> IO CInt

foreign import WINDOWS_CCONV unsafe "windows.h IsDBCSLeadByteEx"
    c_IsDBCSLeadByteEx :: UINT    -- ^ CodePage
                       -> BYTE    -- ^ TestChar
                       -> IO BOOL

-- | Returns a slow but correct implementation of TextEncoding using the Win32 API.
--
-- This is useful for supporting DBCS text encoding on the console without having to statically link
-- in huge code tables into all of our executables, or just as a fallback mechanism if a new code page
-- is introduced that we don't know how to deal with ourselves yet.
mkCodePageEncoding :: CodingFailureMode -> Word32 -> TextEncoding
mkCodePageEncoding cfm cp
  = TextEncoding {
        textEncodingName = "CP" ++ show cp,
        mkTextDecoder = newCP (recoverDecode cfm) cpDecode cp,
        mkTextEncoder = newCP (recoverEncode cfm) cpEncode cp
      }

newCP :: (Buffer from -> Buffer to -> IO (Buffer from, Buffer to))
      -> (Word32 -> Int -> CodeBuffer from to)
      -> Word32
      -> IO (BufferCodec from to ())
newCP rec fn cp = do
  -- Fail early if the code page doesn't exist, to match the behaviour of the IConv TextEncoding
  max_char_size <- alloca $ \cpinfo_ptr -> do
    success <- c_GetCPInfo cp cpinfo_ptr
    when (not success) $ throwGetLastError ("GetCPInfo " ++ show cp)
    fmap (fromIntegral . maxCharSize) $ peek cpinfo_ptr

  debugIO $ "GetCPInfo " ++ show cp ++ " = " ++ show max_char_size

  return $ BufferCodec {
    encode = fn cp max_char_size,
    recover = rec,
    close  = return (),
    -- Windows doesn't supply a way to save/restore the state and doesn't need one
    -- since it's a dumb string->string API rather than a clever streaming one.
    getState = return (),
    setState = const $ return ()
  }

utf16_native_encode' :: EncodeBuffer
utf16_native_decode' :: DecodeBuffer
#if defined(WORDS_BIGENDIAN)
utf16_native_encode' = utf16be_encode
utf16_native_decode' = utf16be_decode
#else
utf16_native_encode' = utf16le_encode
utf16_native_decode' = utf16le_decode
#endif

saner :: CodeBuffer from to
      -> Buffer from -> Buffer to
      -> IO (CodingProgress, Int, Buffer from, Buffer to)
saner code ibuf obuf = do
  (why, ibuf', obuf') <- code ibuf obuf
  -- Weird but true: the UTF16 codes have a special case (see the "done" functions)
  -- whereby if they entirely consume the input instead of returning an input buffer
  -- that is empty because bufL has reached bufR, they return a buffer that is empty
  -- because bufL = bufR = 0.
  --
  -- This is really very odd and confusing for our code that expects the difference
  -- between the old and new input buffer bufLs to indicate the number of elements
  -- that were consumed!
  --
  -- We fix it by explicitly extracting an integer which is the # of things consumed, like so:
  if isEmptyBuffer ibuf'
   then return (InputUnderflow, bufferElems ibuf,       ibuf', obuf')
   else return (why,            bufL ibuf' - bufL ibuf, ibuf', obuf')

byteView :: Buffer CWchar -> Buffer Word8
byteView (Buffer {..}) = Buffer { bufState = bufState, bufRaw = castForeignPtr bufRaw, bufSize = bufSize * 2, bufL = bufL * 2, bufR = bufR * 2 }

cwcharView :: Buffer Word8 -> Buffer CWchar
cwcharView (Buffer {..}) = Buffer { bufState = bufState, bufRaw = castForeignPtr bufRaw, bufSize = half bufSize, bufL = half bufL, bufR = half bufR }
  where half x = case x `divMod` 2 of (y, 0) -> y
                                      _      -> errorWithoutStackTrace "cwcharView: utf16_(encode|decode) (wrote out|consumed) non multiple-of-2 number of bytes"

utf16_native_encode :: CodeBuffer Char CWchar
utf16_native_encode ibuf obuf = do
  (why, ibuf, obuf) <- utf16_native_encode' ibuf (byteView obuf)
  return (why, ibuf, cwcharView obuf)

utf16_native_decode :: CodeBuffer CWchar Char
utf16_native_decode ibuf obuf = do
  (why, ibuf, obuf) <- utf16_native_decode' (byteView ibuf) obuf
  return (why, cwcharView ibuf, obuf)

cpDecode :: Word32 -> Int -> DecodeBuffer
cpDecode cp max_char_size = \ibuf obuf -> do
#if defined(CHARBUF_UTF16)
    let mbuf = obuf
#else
    -- FIXME: share the buffer between runs, even if the buffer is not the perfect size
    let sz =       (bufferElems ibuf * 2)     -- I guess in the worst case the input CP text consists of 1-byte sequences that map entirely to things outside the BMP and so require 2 UTF-16 chars
             `min` (bufferAvailable obuf * 2) -- In the best case, each pair of UTF-16 points becomes a single UTF-32 point
    mbuf <- newBuffer (2 * sz) sz WriteBuffer :: IO (Buffer CWchar)
#endif
    debugIO $ "cpDecode " ++ summaryBuffer ibuf ++ " " ++ summaryBuffer mbuf
    (why1, ibuf', mbuf') <- cpRecode try' is_valid_prefix max_char_size 1 0 1 ibuf mbuf
    debugIO $ "cpRecode (cpDecode) = " ++ show why1 ++ " " ++ summaryBuffer ibuf' ++ " " ++ summaryBuffer mbuf'
#if defined(CHARBUF_UTF16)
    return (why1, ibuf', mbuf')
#else
    -- Convert as much UTF-16 as possible to UTF-32. Note that it's impossible for this to fail
    -- due to illegal characters since the output from Window's encoding function should be correct UTF-16.
    -- However, it's perfectly possible to run out of either output or input buffer.
    debugIO $ "utf16_native_decode " ++ summaryBuffer mbuf' ++ " " ++ summaryBuffer obuf
    (why2, target_utf16_count, mbuf', obuf) <- saner utf16_native_decode (mbuf' { bufState = ReadBuffer }) obuf
    debugIO $ "utf16_native_decode = " ++ show why2 ++ " " ++ summaryBuffer mbuf' ++ " " ++ summaryBuffer obuf
    case why2 of
      -- If we successfully translate all of the UTF-16 buffer, we need to know why we couldn't get any more
      -- UTF-16 out of the Windows API
      InputUnderflow | isEmptyBuffer mbuf' -> return (why1, ibuf', obuf)
                     | otherwise           -> errorWithoutStackTrace "cpDecode: impossible underflown UTF-16 buffer"
      -- InvalidSequence should be impossible since mbuf' is output from Windows.
      InvalidSequence -> errorWithoutStackTrace "InvalidSequence on output of Windows API"
      -- If we run out of space in obuf, we need to ask for more output buffer space, while also returning
      -- the characters we have managed to consume so far.
      OutputUnderflow -> do
        -- We have an interesting problem here similar to the cpEncode case where we have to figure out how much
        -- of the byte buffer was consumed to reach as far as the last UTF-16 character we actually decoded to UTF-32 OK.
        --
        -- The minimum number of bytes it could take is half the number of UTF-16 chars we got on the output, since
        -- one byte could theoretically generate two UTF-16 characters.
        -- The common case (ASCII text) is that every byte in the input maps to a single UTF-16 character.
        -- In the worst case max_char_size bytes map to each UTF-16 character.
        byte_count <- bSearch "cpDecode" (cpRecode try' is_valid_prefix max_char_size 1 0 1) ibuf mbuf target_utf16_count (target_utf16_count `div` 2) target_utf16_count (target_utf16_count * max_char_size)
        return (OutputUnderflow, bufferRemove byte_count ibuf, obuf)
#endif
  where
    is_valid_prefix = c_IsDBCSLeadByteEx cp
    try' iptr icnt optr ocnt
     -- MultiByteToWideChar does surprising things if you have ocnt == 0
     | ocnt == 0 = return (Left True)
     | otherwise = do
        err <- c_MultiByteToWideChar (fromIntegral cp) 8 -- MB_ERR_INVALID_CHARS == 8: Fail if an invalid input character is encountered
                                     iptr (fromIntegral icnt) optr (fromIntegral ocnt)
        debugIO $ "MultiByteToWideChar " ++ show cp ++ " 8 " ++ show iptr ++ " " ++ show icnt ++ " " ++ show optr ++ " " ++ show ocnt ++ "\n = " ++ show err
        case err of
          -- 0 indicates that we did not succeed
          0 -> do
            err <- getLastError
            case err of
                122  -> return (Left True)
                1113 -> return (Left False)
                _    -> failWith "MultiByteToWideChar" err
          wrote_chars -> return (Right (fromIntegral wrote_chars))

cpEncode :: Word32 -> Int -> EncodeBuffer
cpEncode cp _max_char_size = \ibuf obuf -> do
#if defined(CHARBUF_UTF16)
    let mbuf' = ibuf
#else
    -- FIXME: share the buffer between runs, even though that means we can't size the buffer as we want.
    let sz =       (bufferElems ibuf * 2)     -- UTF-32 always uses 4 bytes. UTF-16 uses at most 4 bytes.
             `min` (bufferAvailable obuf * 2) -- In the best case, each pair of UTF-16 points fits into only 1 byte
    mbuf <- newBuffer (2 * sz) sz WriteBuffer

    -- Convert as much UTF-32 as possible to UTF-16. NB: this can't fail due to output underflow
    -- since we sized the output buffer correctly. However, it could fail due to an illegal character
    -- in the input if it encounters a lone surrogate. In this case, our recovery will be applied as normal.
    (why1, ibuf', mbuf') <- utf16_native_encode ibuf mbuf
#endif
    debugIO $ "\ncpEncode " ++ summaryBuffer mbuf' ++ " " ++ summaryBuffer obuf
    (why2, target_utf16_count, mbuf', obuf) <- saner (cpRecode try' is_valid_prefix 2 1 1 0) (mbuf' { bufState = ReadBuffer }) obuf
    debugIO $ "cpRecode (cpEncode) = " ++ show why2 ++ " " ++ summaryBuffer mbuf' ++ " " ++ summaryBuffer obuf
#if defined(CHARBUF_UTF16)
    return (why2, mbuf', obuf)
#else
    case why2 of
      -- If we successfully translate all of the UTF-16 buffer, we need to know why
      -- we weren't able to get any more UTF-16 out of the UTF-32 buffer
      InputUnderflow | isEmptyBuffer mbuf' -> return (why1, ibuf', obuf)
                     | otherwise           -> errorWithoutStackTrace "cpEncode: impossible underflown UTF-16 buffer"
      -- With OutputUnderflow/InvalidSequence we only care about the failings of the UTF-16->CP translation.
      -- Yes, InvalidSequence is possible even though mbuf' is guaranteed to be valid UTF-16, because
      -- the code page may not be able to represent the encoded Unicode codepoint.
      _ -> do
        -- Here is an interesting problem. If we have only managed to translate part of the mbuf'
        -- then we need to return an ibuf which has consumed exactly those bytes required to obtain
        -- that part of the mbuf'. To reconstruct this information, we binary search for the number of
        -- UTF-32 characters required to get the consumed count of UTF-16 characters:
        --
        -- When dealing with data from the BMP (the common case), consuming N UTF-16 characters will be the same as consuming N
        -- UTF-32 characters. We start our search there so that most binary searches will terminate in a single iteration.
        -- Furthermore, the absolute minimum number of UTF-32 characters this can correspond to is 1/2 the UTF-16 byte count
        -- (this will be realised when the input data is entirely not in the BMP).
        utf32_count <- bSearch "cpEncode" utf16_native_encode ibuf mbuf target_utf16_count (target_utf16_count `div` 2) target_utf16_count target_utf16_count
        return (why2, bufferRemove utf32_count ibuf, obuf)
#endif
  where
    -- Single characters should be mappable to bytes. If they aren't supported by the CP then we have an invalid input sequence.
    is_valid_prefix _ = return False

    try' iptr icnt optr ocnt
     -- WideCharToMultiByte does surprising things if you call it with ocnt == 0
     | ocnt == 0 = return (Left True)
     | otherwise = alloca $ \defaulted_ptr -> do
      poke defaulted_ptr False
      err <- c_WideCharToMultiByte (fromIntegral cp) 0 -- NB: the WC_ERR_INVALID_CHARS flag is uselses: only has an effect with the UTF-8 code page
                                   iptr (fromIntegral icnt) optr (fromIntegral ocnt)
                                   nullPtr defaulted_ptr
      defaulted <- peek defaulted_ptr
      debugIO $ "WideCharToMultiByte " ++ show cp ++ " 0 " ++ show iptr ++ " " ++ show icnt ++ " " ++ show optr ++ " " ++ show ocnt ++ " NULL " ++ show defaulted_ptr ++ "\n = " ++ show err ++ ", " ++ show defaulted
      case err of
          -- 0 indicates that we did not succeed
          0 -> do
            err <- getLastError
            case err of
                122  -> return (Left True)
                1113 -> return (Left False)
                _    -> failWith "WideCharToMultiByte" err
          wrote_bytes | defaulted -> return (Left False)
                      | otherwise -> return (Right (fromIntegral wrote_bytes))

bSearch :: String
        -> CodeBuffer from to
        -> Buffer from -> Buffer to -- From buffer (crucial data source) and to buffer (temporary storage only). To buffer must be empty (L=R).
        -> Int               -- Target size of to buffer
        -> Int -> Int -> Int -- Binary search min, mid, max
        -> IO Int            -- Size of from buffer required to reach target size of to buffer
bSearch msg code ibuf mbuf target_to_elems = go
  where
    go mn md mx = do
      -- NB: this loop repeatedly reencodes on top of mbuf using a varying fraction of ibuf. It doesn't
      -- matter if we blast the contents of mbuf since we already consumed all of the contents we are going to use.
      (_why, ibuf, mbuf) <- code (ibuf { bufR = bufL ibuf + md }) mbuf
      debugIO $ "code (bSearch " ++ msg ++ ") " ++ show md ++ " = " ++ show _why ++ ", " ++ summaryBuffer ibuf ++ summaryBuffer mbuf
      -- The normal case is to get InputUnderflow here, which indicates that coding basically
      -- terminated normally.
      --
      -- However, InvalidSequence is also possible if we are being called from cpDecode if we
      -- have just been unlucky enough to set md so that ibuf straddles a byte boundary.
      -- In this case we have to be really careful, because we don't want to report that
      -- "md" elements is the right number when in actual fact we could have had md-1 input
      -- elements and still produced the same number of bufferElems in mbuf.
      --
      -- In fact, we have to worry about this possibility even if we get InputUnderflow
      -- since that will report InputUnderflow rather than InvalidSequence if the buffer
      -- ends in a valid lead byte. So the expedient thing to do is simply to check if
      -- the input buffer was entirely consumed.
      --
      -- When called from cpDecode, OutputUnderflow is also possible.
      --
      -- Luckily if we have InvalidSequence/OutputUnderflow and we do not appear to have reached
      -- the target, what we should do is the same as normal because the fraction of ibuf that our
      -- first "code" coded successfully must be invalid-sequence-free, and ibuf will always
      -- have been decoded as far as the first invalid sequence in it.
      case bufferElems mbuf `compare` target_to_elems of
        -- Coding n "from" chars from the input yields exactly as many "to" chars
        -- as were consumed by the recode. All is peachy:
        EQ -> debugIO ("bSearch = " ++ show solution) >> return solution
          where solution = md - bufferElems ibuf
        -- If we encoded fewer "to" characters than the target number, try again with more "from" characters (and vice-versa)
        LT -> go' (md+1) mx
        GT -> go' mn (md-1)
    go' mn mx | mn <= mx  = go mn (mn + ((mx - mn) `div` 2)) mx
              | otherwise = errorWithoutStackTrace $ "bSearch(" ++ msg ++ "): search crossed! " ++ show (summaryBuffer ibuf, summaryBuffer mbuf, target_to_elems, mn, mx)

cpRecode :: forall from to. Storable from
         => (Ptr from -> Int -> Ptr to -> Int -> IO (Either Bool Int))
         -> (from -> IO Bool)
         -> Int -- ^ Maximum length of a complete translatable sequence in the input (e.g. 2 if the input is UTF-16, 1 if the input is a SBCS, 2 is the input is a DBCS). Must be at least 1.
         -> Int -- ^ Minimum number of output elements per complete translatable sequence in the input (almost certainly 1)
         -> Int -> Int
         -> CodeBuffer from to
cpRecode try' is_valid_prefix max_i_size min_o_size iscale oscale = go
  where
    go :: CodeBuffer from to
    go ibuf obuf | isEmptyBuffer ibuf                = return (InputUnderflow,  ibuf, obuf)
                 | bufferAvailable obuf < min_o_size = return (OutputUnderflow, ibuf, obuf)
                 | otherwise                         = try (bufferElems ibuf `min` ((max_i_size * bufferAvailable obuf) `div` min_o_size)) seek_smaller
      where
        done why = return (why, ibuf, obuf)

        seek_smaller n longer_was_valid
          -- In this case, we can't shrink any further via any method. Calling (try 0) wouldn't be right because that will always claim InputUnderflow...
          | n <= 1 = if longer_was_valid
                      -- try m (where m >= n) was valid but we overflowed the output buffer with even a single input element
                      then done OutputUnderflow
                      -- there was no initial valid sequence in the input, but it might just be a truncated buffer - we need to check
                      else do byte <- withBuffer ibuf $ \ptr -> peekElemOff ptr (bufL ibuf)
                              valid_prefix <- is_valid_prefix byte
                              done (if valid_prefix && bufferElems ibuf < max_i_size then InputUnderflow else InvalidSequence)
          -- If we're already looking at very small buffers, try every n down to 1, to ensure we spot as long a sequence as exists while avoiding trying 0.
          -- Doing it this way ensures that we spot a single initial sequence of length <= max_i_size if any such exists.
          | n < 2 * max_i_size = try (n - 1) (\pred_n pred_n_was_valid -> seek_smaller pred_n (longer_was_valid || pred_n_was_valid))
          -- Otherwise, try a binary chop to try to either get the prefix before the invalid input, or shrink the output down so it fits
          -- in the output buffer. After the chop, try to consume extra input elements to try to recover as much of the sequence as possible if we
          -- end up chopping a multi-element input sequence into two parts.
          --
          -- Note that since max_i_size >= 1:
          --  * (n `div` 2) >= 1, so we don't try 0
          --  * ((n `div` 2) + (max_i_size - 1)) < n, so we don't get into a loop where (seek_smaller n) calls post_divide (n `div` 2) calls (seek_smaller n)
          | let n' = n `div` 2 = try n' (post_divide n' longer_was_valid)

        post_divide _  _                n True  = seek_smaller n True
        post_divide n' longer_was_valid n False | n < n' + max_i_size - 1 = try (n + 1) (post_divide n' longer_was_valid) -- There's still a chance..
                                                | otherwise               = seek_smaller n' longer_was_valid              -- No amount of recovery could save us :(

        try n k_fail = withBuffer ibuf $ \iptr -> withBuffer obuf $ \optr -> do
          ei_err_wrote <- try' (iptr `plusPtr` (bufL ibuf `shiftL` iscale)) n
                               (optr `plusPtr` (bufR obuf `shiftL` oscale)) (bufferAvailable obuf)
          debugIO $ "try " ++ show n ++ " = " ++ show ei_err_wrote
          case ei_err_wrote of
            -- ERROR_INSUFFICIENT_BUFFER: A supplied buffer size was not large enough, or it was incorrectly set to NULL.
            Left True  -> k_fail n True
            -- ERROR_NO_UNICODE_TRANSLATION: Invalid Unicode was found in a string.
            Left False -> k_fail n False
            -- Must have interpreted all given bytes successfully
            -- We need to iterate until we have consumed the complete contents of the buffer
            Right wrote_elts -> go (bufferRemove n ibuf) (obuf { bufR = bufR obuf + wrote_elts })