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

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

-- Required for WORDS_BIGENDIAN
#include <ghcautoconf.h>

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 hiding (LPCSTR)
import GHC.ForeignPtr (castForeignPtr)

import System.Posix.Internals

#if defined(javascript_HOST_ARCH)
mkCodePageEncoding :: String
mkCodePageEncoding = ""
#else

c_DEBUG_DUMP :: Bool
c_DEBUG_DUMP :: Bool
c_DEBUG_DUMP = Bool
False

debugIO :: String -> IO ()
debugIO :: String -> IO ()
debugIO String
s
 | Bool
c_DEBUG_DUMP = String -> IO ()
puts String
s
 | Bool
otherwise    = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

#include "windows_cconv.h"

type LPCSTR = Ptr Word8


mAX_DEFAULTCHAR :: Int
mAX_DEFAULTCHAR :: Int
mAX_DEFAULTCHAR = Int
2

mAX_LEADBYTES :: Int
mAX_LEADBYTES :: Int
mAX_LEADBYTES = Int
12

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

-- | @since 4.7.0.0
instance Storable CPINFO where
    sizeOf :: CPINFO -> Int
sizeOf    CPINFO
_ = Word32 -> Int
forall a. Storable a => a -> Int
sizeOf (Word32
forall a. HasCallStack => a
undefined :: UINT) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
mAX_DEFAULTCHAR Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
mAX_LEADBYTES) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Word8 -> Int
forall a. Storable a => a -> Int
sizeOf (Word8
forall a. HasCallStack => a
undefined :: BYTE)
    alignment :: CPINFO -> Int
alignment CPINFO
_ = CInt -> Int
forall a. Storable a => a -> Int
alignment (CInt
forall a. HasCallStack => a
undefined :: CInt)
    peek :: Ptr CPINFO -> IO CPINFO
peek Ptr CPINFO
ptr = do
      Ptr Word32
ptr <- Ptr Word32 -> IO (Ptr Word32)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word32 -> IO (Ptr Word32)) -> Ptr Word32 -> IO (Ptr Word32)
forall a b. (a -> b) -> a -> b
$ Ptr CPINFO -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr Ptr CPINFO
ptr
      Word32
a <- Ptr Word32 -> IO Word32
forall a. Storable a => Ptr a -> IO a
peek Ptr Word32
ptr
      Ptr Word8
ptr <- Ptr Word8 -> IO (Ptr Word8)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$ Ptr Word32 -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr (Ptr Word32 -> Ptr Word8) -> Ptr Word32 -> Ptr Word8
forall a b. (a -> b) -> a -> b
$ Ptr Word32 -> Int -> Ptr Word32
forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr Word32
ptr Int
1
      [Word8]
b <- Int -> Ptr Word8 -> IO [Word8]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
mAX_DEFAULTCHAR Ptr Word8
ptr
      [Word8]
c <- Int -> Ptr Word8 -> IO [Word8]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
mAX_LEADBYTES   (Ptr Word8 -> Int -> Ptr Word8
forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr Word8
ptr Int
mAX_DEFAULTCHAR)
      CPINFO -> IO CPINFO
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CPINFO -> IO CPINFO) -> CPINFO -> IO CPINFO
forall a b. (a -> b) -> a -> b
$ Word32 -> [Word8] -> [Word8] -> CPINFO
CPINFO Word32
a [Word8]
b [Word8]
c
    poke :: Ptr CPINFO -> CPINFO -> IO ()
poke Ptr CPINFO
ptr CPINFO
val = do
      Ptr Word32
ptr <- Ptr Word32 -> IO (Ptr Word32)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word32 -> IO (Ptr Word32)) -> Ptr Word32 -> IO (Ptr Word32)
forall a b. (a -> b) -> a -> b
$ Ptr CPINFO -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr Ptr CPINFO
ptr
      Ptr Word32 -> Word32 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word32
ptr (CPINFO -> Word32
maxCharSize CPINFO
val)
      Ptr Word8
ptr <- Ptr Word8 -> IO (Ptr Word8)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$ Ptr Word32 -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr (Ptr Word32 -> Ptr Word8) -> Ptr Word32 -> Ptr Word8
forall a b. (a -> b) -> a -> b
$ Ptr Word32 -> Int -> Ptr Word32
forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr Word32
ptr Int
1
      String -> Int -> Ptr Word8 -> [Word8] -> IO ()
forall a. Storable a => String -> Int -> Ptr a -> [a] -> IO ()
pokeArray' String
"CPINFO.defaultChar" Int
mAX_DEFAULTCHAR Ptr Word8
ptr                              (CPINFO -> [Word8]
defaultChar CPINFO
val)
      String -> Int -> Ptr Word8 -> [Word8] -> IO ()
forall a. Storable a => String -> Int -> Ptr a -> [a] -> IO ()
pokeArray' String
"CPINFO.leadByte"    Int
mAX_LEADBYTES   (Ptr Word8 -> Int -> Ptr Word8
forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr Word8
ptr Int
mAX_DEFAULTCHAR) (CPINFO -> [Word8]
leadByte CPINFO
val)

pokeArray' :: Storable a => String -> Int -> Ptr a -> [a] -> IO ()
pokeArray' :: forall a. Storable a => String -> Int -> Ptr a -> [a] -> IO ()
pokeArray' String
msg Int
sz Ptr a
ptr [a]
xs | [a] -> Int
forall a. [a] -> Int
length [a]
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
sz = Ptr a -> [a] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr a
ptr [a]
xs
                         | Bool
otherwise       = String -> IO ()
forall a. String -> a
errorWithoutStackTrace (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sz String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" elements in list but got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall a. [a] -> Int
length [a]
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 :: CodingFailureMode -> Word32 -> TextEncoding
mkCodePageEncoding CodingFailureMode
cfm Word32
cp
  = TextEncoding {
        textEncodingName :: String
textEncodingName = String
"CP" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
cp,
        mkTextDecoder :: IO (TextDecoder ())
mkTextDecoder = (Buffer Word8
 -> Buffer CharBufElem -> IO (Buffer Word8, Buffer CharBufElem))
-> (Word32 -> Int -> CodeBuffer Word8 CharBufElem)
-> Word32
-> IO (TextDecoder ())
forall from to.
(Buffer from -> Buffer to -> IO (Buffer from, Buffer to))
-> (Word32 -> Int -> CodeBuffer from to)
-> Word32
-> IO (BufferCodec from to ())
newCP (CodingFailureMode
-> Buffer Word8
-> Buffer CharBufElem
-> IO (Buffer Word8, Buffer CharBufElem)
recoverDecode CodingFailureMode
cfm) Word32 -> Int -> CodeBuffer Word8 CharBufElem
cpDecode Word32
cp,
        mkTextEncoder :: IO (TextEncoder ())
mkTextEncoder = (Buffer CharBufElem
 -> Buffer Word8 -> IO (Buffer CharBufElem, Buffer Word8))
-> (Word32 -> Int -> CodeBuffer CharBufElem Word8)
-> Word32
-> IO (TextEncoder ())
forall from to.
(Buffer from -> Buffer to -> IO (Buffer from, Buffer to))
-> (Word32 -> Int -> CodeBuffer from to)
-> Word32
-> IO (BufferCodec from to ())
newCP (CodingFailureMode
-> Buffer CharBufElem
-> Buffer Word8
-> IO (Buffer CharBufElem, Buffer Word8)
recoverEncode CodingFailureMode
cfm) Word32 -> Int -> CodeBuffer CharBufElem Word8
cpEncode Word32
cp
      }

newCP :: (Buffer from -> Buffer to -> IO (Buffer from, Buffer to))
      -> (Word32 -> Int -> CodeBuffer from to)
      -> Word32
      -> IO (BufferCodec from to ())
newCP :: forall from to.
(Buffer from -> Buffer to -> IO (Buffer from, Buffer to))
-> (Word32 -> Int -> CodeBuffer from to)
-> Word32
-> IO (BufferCodec from to ())
newCP Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
rec Word32 -> Int -> CodeBuffer from to
fn Word32
cp = do
  -- Fail early if the code page doesn't exist, to match the behaviour of the IConv TextEncoding
  Int
max_char_size <- (Ptr CPINFO -> IO Int) -> IO Int
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CPINFO -> IO Int) -> IO Int)
-> (Ptr CPINFO -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Ptr CPINFO
cpinfo_ptr -> do
    Bool
success <- Word32 -> Ptr CPINFO -> IO Bool
c_GetCPInfo Word32
cp Ptr CPINFO
cpinfo_ptr
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
success) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. String -> IO a
throwGetLastError (String
"GetCPInfo " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
cp)
    (CPINFO -> Int) -> IO CPINFO -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> (CPINFO -> Word32) -> CPINFO -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPINFO -> Word32
maxCharSize) (IO CPINFO -> IO Int) -> IO CPINFO -> IO Int
forall a b. (a -> b) -> a -> b
$ Ptr CPINFO -> IO CPINFO
forall a. Storable a => Ptr a -> IO a
peek Ptr CPINFO
cpinfo_ptr

  String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"GetCPInfo " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
cp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
max_char_size

  BufferCodec from to () -> IO (BufferCodec from to ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BufferCodec from to () -> IO (BufferCodec from to ()))
-> BufferCodec from to () -> IO (BufferCodec from to ())
forall a b. (a -> b) -> a -> b
$ BufferCodec {
    encode :: CodeBuffer from to
encode = Word32 -> Int -> CodeBuffer from to
fn Word32
cp Int
max_char_size,
    recover :: Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
recover = Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
rec,
    close :: IO ()
close  = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
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 :: IO ()
getState = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (),
    setState :: () -> IO ()
setState = IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
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' :: CodeBuffer CharBufElem Word8
utf16_native_encode' = CodeBuffer CharBufElem Word8
utf16le_encode
utf16_native_decode' :: CodeBuffer Word8 CharBufElem
utf16_native_decode' = CodeBuffer Word8 CharBufElem
utf16le_decode
#endif

saner :: CodeBuffer from to
      -> Buffer from -> Buffer to
      -> IO (CodingProgress, Int, Buffer from, Buffer to)
saner :: forall from to.
CodeBuffer from to
-> Buffer from
-> Buffer to
-> IO (CodingProgress, Int, Buffer from, Buffer to)
saner CodeBuffer from to
code Buffer from
ibuf Buffer to
obuf = do
  (CodingProgress
why, Buffer from
ibuf', Buffer to
obuf') <- CodeBuffer from to
code Buffer from
ibuf Buffer to
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 Buffer from -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer Buffer from
ibuf'
   then (CodingProgress, Int, Buffer from, Buffer to)
-> IO (CodingProgress, Int, Buffer from, Buffer to)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CodingProgress
InputUnderflow, Buffer from -> Int
forall e. Buffer e -> Int
bufferElems Buffer from
ibuf,       Buffer from
ibuf', Buffer to
obuf')
   else (CodingProgress, Int, Buffer from, Buffer to)
-> IO (CodingProgress, Int, Buffer from, Buffer to)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CodingProgress
why,            Buffer from -> Int
forall e. Buffer e -> Int
bufL Buffer from
ibuf' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Buffer from -> Int
forall e. Buffer e -> Int
bufL Buffer from
ibuf, Buffer from
ibuf', Buffer to
obuf')

byteView :: Buffer CWchar -> Buffer Word8
byteView :: Buffer CWchar -> Buffer Word8
byteView (Buffer {Int
Word64
RawBuffer CWchar
BufferState
bufL :: forall e. Buffer e -> Int
bufRaw :: RawBuffer CWchar
bufState :: BufferState
bufSize :: Int
bufOffset :: Word64
bufL :: Int
bufR :: Int
bufRaw :: forall e. Buffer e -> RawBuffer e
bufState :: forall e. Buffer e -> BufferState
bufSize :: forall e. Buffer e -> Int
bufOffset :: forall e. Buffer e -> Word64
bufR :: forall e. Buffer e -> Int
..}) = Buffer { bufState :: BufferState
bufState = BufferState
bufState, bufRaw :: RawBuffer Word8
bufRaw = RawBuffer CWchar -> RawBuffer Word8
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr RawBuffer CWchar
bufRaw, bufSize :: Int
bufSize = Int
bufSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2, bufOffset :: Word64
bufOffset = Word64
bufOffset, bufL :: Int
bufL = Int
bufL Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2, bufR :: Int
bufR = Int
bufR Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 }

cwcharView :: Buffer Word8 -> Buffer CWchar
cwcharView :: Buffer Word8 -> Buffer CWchar
cwcharView (Buffer {Int
Word64
RawBuffer Word8
BufferState
bufL :: forall e. Buffer e -> Int
bufRaw :: forall e. Buffer e -> RawBuffer e
bufState :: forall e. Buffer e -> BufferState
bufSize :: forall e. Buffer e -> Int
bufOffset :: forall e. Buffer e -> Word64
bufR :: forall e. Buffer e -> Int
bufRaw :: RawBuffer Word8
bufState :: BufferState
bufSize :: Int
bufOffset :: Word64
bufL :: Int
bufR :: Int
..}) = Buffer { bufState :: BufferState
bufState = BufferState
bufState, bufRaw :: RawBuffer CWchar
bufRaw = RawBuffer Word8 -> RawBuffer CWchar
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr RawBuffer Word8
bufRaw, bufSize :: Int
bufSize = Int -> Int
forall {a}. Integral a => a -> a
half Int
bufSize, bufOffset :: Word64
bufOffset = Word64
bufOffset, bufL :: Int
bufL = Int -> Int
forall {a}. Integral a => a -> a
half Int
bufL, bufR :: Int
bufR = Int -> Int
forall {a}. Integral a => a -> a
half Int
bufR }
  where half :: a -> a
half a
x = case a
x a -> a -> (a, a)
forall a. Integral a => a -> a -> (a, a)
`divMod` a
2 of (a
y, a
0) -> a
y
                                      (a, a)
_      -> String -> a
forall a. String -> a
errorWithoutStackTrace String
"cwcharView: utf16_(encode|decode) (wrote out|consumed) non multiple-of-2 number of bytes"

utf16_native_encode :: CodeBuffer Char CWchar
utf16_native_encode :: CodeBuffer CharBufElem CWchar
utf16_native_encode Buffer CharBufElem
ibuf Buffer CWchar
obuf = do
  (CodingProgress
why, Buffer CharBufElem
ibuf, Buffer Word8
obuf) <- CodeBuffer CharBufElem Word8
utf16_native_encode' Buffer CharBufElem
ibuf (Buffer CWchar -> Buffer Word8
byteView Buffer CWchar
obuf)
  (CodingProgress, Buffer CharBufElem, Buffer CWchar)
-> IO (CodingProgress, Buffer CharBufElem, Buffer CWchar)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CodingProgress
why, Buffer CharBufElem
ibuf, Buffer Word8 -> Buffer CWchar
cwcharView Buffer Word8
obuf)

utf16_native_decode :: CodeBuffer CWchar Char
utf16_native_decode :: CodeBuffer CWchar CharBufElem
utf16_native_decode Buffer CWchar
ibuf Buffer CharBufElem
obuf = do
  (CodingProgress
why, Buffer Word8
ibuf, Buffer CharBufElem
obuf) <- CodeBuffer Word8 CharBufElem
utf16_native_decode' (Buffer CWchar -> Buffer Word8
byteView Buffer CWchar
ibuf) Buffer CharBufElem
obuf
  (CodingProgress, Buffer CWchar, Buffer CharBufElem)
-> IO (CodingProgress, Buffer CWchar, Buffer CharBufElem)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CodingProgress
why, Buffer Word8 -> Buffer CWchar
cwcharView Buffer Word8
ibuf, Buffer CharBufElem
obuf)

cpDecode :: Word32 -> Int -> DecodeBuffer
cpDecode :: Word32 -> Int -> CodeBuffer Word8 CharBufElem
cpDecode Word32
cp Int
max_char_size = \Buffer Word8
ibuf Buffer CharBufElem
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 :: Int
sz =       (Buffer Word8 -> Int
forall e. Buffer e -> Int
bufferElems Buffer Word8
ibuf Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
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
             Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` (Buffer CharBufElem -> Int
forall e. Buffer e -> Int
bufferAvailable Buffer CharBufElem
obuf Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) -- In the best case, each pair of UTF-16 points becomes a single UTF-32 point
    Buffer CWchar
mbuf <- Int -> Int -> BufferState -> IO (Buffer CWchar)
forall e. Int -> Int -> BufferState -> IO (Buffer e)
newBuffer (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sz) Int
sz BufferState
WriteBuffer :: IO (Buffer CWchar)
#endif
    String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"cpDecode " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer Word8 -> String
forall a. Buffer a -> String
summaryBuffer Buffer Word8
ibuf String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer CWchar -> String
forall a. Buffer a -> String
summaryBuffer Buffer CWchar
mbuf
    (CodingProgress
why1, Buffer Word8
ibuf', Buffer CWchar
mbuf') <- (Ptr Word8 -> Int -> Ptr CWchar -> Int -> IO (Either Bool Int))
-> (Word8 -> IO Bool)
-> Int
-> Int
-> Int
-> Int
-> CodeBuffer Word8 CWchar
forall from to.
Storable from =>
(Ptr from -> Int -> Ptr to -> Int -> IO (Either Bool Int))
-> (from -> IO Bool)
-> Int
-> Int
-> Int
-> Int
-> CodeBuffer from to
cpRecode Ptr Word8 -> Int -> Ptr CWchar -> Int -> IO (Either Bool Int)
forall {a} {a} {b}.
(Integral a, Integral a, Show a, Show a, Num b) =>
Ptr Word8 -> a -> Ptr CWchar -> a -> IO (Either Bool b)
try' Word8 -> IO Bool
is_valid_prefix Int
max_char_size Int
1 Int
0 Int
1 Buffer Word8
ibuf Buffer CWchar
mbuf
    String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"cpRecode (cpDecode) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CodingProgress -> String
forall a. Show a => a -> String
show CodingProgress
why1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer Word8 -> String
forall a. Buffer a -> String
summaryBuffer Buffer Word8
ibuf' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer CWchar -> String
forall a. Buffer a -> String
summaryBuffer Buffer CWchar
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.
    String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"utf16_native_decode " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer CWchar -> String
forall a. Buffer a -> String
summaryBuffer Buffer CWchar
mbuf' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer CharBufElem -> String
forall a. Buffer a -> String
summaryBuffer Buffer CharBufElem
obuf
    (CodingProgress
why2, Int
target_utf16_count, Buffer CWchar
mbuf', Buffer CharBufElem
obuf) <- CodeBuffer CWchar CharBufElem
-> Buffer CWchar
-> Buffer CharBufElem
-> IO (CodingProgress, Int, Buffer CWchar, Buffer CharBufElem)
forall from to.
CodeBuffer from to
-> Buffer from
-> Buffer to
-> IO (CodingProgress, Int, Buffer from, Buffer to)
saner CodeBuffer CWchar CharBufElem
utf16_native_decode (Buffer CWchar
mbuf' { bufState = ReadBuffer }) Buffer CharBufElem
obuf
    String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"utf16_native_decode = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CodingProgress -> String
forall a. Show a => a -> String
show CodingProgress
why2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer CWchar -> String
forall a. Buffer a -> String
summaryBuffer Buffer CWchar
mbuf' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer CharBufElem -> String
forall a. Buffer a -> String
summaryBuffer Buffer CharBufElem
obuf
    case CodingProgress
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
      CodingProgress
InputUnderflow | Buffer CWchar -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer Buffer CWchar
mbuf' -> (CodingProgress, Buffer Word8, Buffer CharBufElem)
-> IO (CodingProgress, Buffer Word8, Buffer CharBufElem)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CodingProgress
why1, Buffer Word8
ibuf', Buffer CharBufElem
obuf)
                     | Bool
otherwise           -> String -> IO (CodingProgress, Buffer Word8, Buffer CharBufElem)
forall a. String -> a
errorWithoutStackTrace String
"cpDecode: impossible underflown UTF-16 buffer"
      -- InvalidSequence should be impossible since mbuf' is output from Windows.
      CodingProgress
InvalidSequence -> String -> IO (CodingProgress, Buffer Word8, Buffer CharBufElem)
forall a. String -> a
errorWithoutStackTrace String
"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.
      CodingProgress
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.
        Int
byte_count <- String
-> CodeBuffer Word8 CWchar
-> Buffer Word8
-> Buffer CWchar
-> Int
-> Int
-> Int
-> Int
-> IO Int
forall from to.
String
-> CodeBuffer from to
-> Buffer from
-> Buffer to
-> Int
-> Int
-> Int
-> Int
-> IO Int
bSearch String
"cpDecode" ((Ptr Word8 -> Int -> Ptr CWchar -> Int -> IO (Either Bool Int))
-> (Word8 -> IO Bool)
-> Int
-> Int
-> Int
-> Int
-> CodeBuffer Word8 CWchar
forall from to.
Storable from =>
(Ptr from -> Int -> Ptr to -> Int -> IO (Either Bool Int))
-> (from -> IO Bool)
-> Int
-> Int
-> Int
-> Int
-> CodeBuffer from to
cpRecode Ptr Word8 -> Int -> Ptr CWchar -> Int -> IO (Either Bool Int)
forall {a} {a} {b}.
(Integral a, Integral a, Show a, Show a, Num b) =>
Ptr Word8 -> a -> Ptr CWchar -> a -> IO (Either Bool b)
try' Word8 -> IO Bool
is_valid_prefix Int
max_char_size Int
1 Int
0 Int
1) Buffer Word8
ibuf Buffer CWchar
mbuf Int
target_utf16_count (Int
target_utf16_count Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int
target_utf16_count (Int
target_utf16_count Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
max_char_size)
        (CodingProgress, Buffer Word8, Buffer CharBufElem)
-> IO (CodingProgress, Buffer Word8, Buffer CharBufElem)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CodingProgress
OutputUnderflow, Int -> Buffer Word8 -> Buffer Word8
forall e. Int -> Buffer e -> Buffer e
bufferRemove Int
byte_count Buffer Word8
ibuf, Buffer CharBufElem
obuf)
#endif
  where
    is_valid_prefix :: Word8 -> IO Bool
is_valid_prefix = Word32 -> Word8 -> IO Bool
c_IsDBCSLeadByteEx Word32
cp
    try' :: Ptr Word8 -> a -> Ptr CWchar -> a -> IO (Either Bool b)
try' Ptr Word8
iptr a
icnt Ptr CWchar
optr a
ocnt
     -- MultiByteToWideChar does surprising things if you have ocnt == 0
     | a
ocnt a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = Either Bool b -> IO (Either Bool b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Either Bool b
forall a b. a -> Either a b
Left Bool
True)
     | Bool
otherwise = do
        CInt
err <- Word32
-> Word32 -> Ptr Word8 -> CInt -> Ptr CWchar -> CInt -> IO CInt
c_MultiByteToWideChar (Word32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
cp) Word32
8 -- MB_ERR_INVALID_CHARS == 8: Fail if an invalid input character is encountered
                                     Ptr Word8
iptr (a -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
icnt) Ptr CWchar
optr (a -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
ocnt)
        String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"MultiByteToWideChar " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
cp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 8 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ptr Word8 -> String
forall a. Show a => a -> String
show Ptr Word8
iptr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
icnt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ptr CWchar -> String
forall a. Show a => a -> String
show Ptr CWchar
optr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
ocnt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
err
        case CInt
err of
          -- 0 indicates that we did not succeed
          CInt
0 -> do
            Word32
err <- IO Word32
getLastError
            case Word32
err of
                Word32
122  -> Either Bool b -> IO (Either Bool b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Either Bool b
forall a b. a -> Either a b
Left Bool
True)
                Word32
1113 -> Either Bool b -> IO (Either Bool b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Either Bool b
forall a b. a -> Either a b
Left Bool
False)
                Word32
_    -> String -> Word32 -> IO (Either Bool b)
forall a. String -> Word32 -> IO a
failWith String
"MultiByteToWideChar" Word32
err
          CInt
wrote_chars -> Either Bool b -> IO (Either Bool b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Either Bool b
forall a b. b -> Either a b
Right (CInt -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
wrote_chars))

cpEncode :: Word32 -> Int -> EncodeBuffer
cpEncode :: Word32 -> Int -> CodeBuffer CharBufElem Word8
cpEncode Word32
cp Int
_max_char_size = \Buffer CharBufElem
ibuf Buffer Word8
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 :: Int
sz =       (Buffer CharBufElem -> Int
forall e. Buffer e -> Int
bufferElems Buffer CharBufElem
ibuf Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)     -- UTF-32 always uses 4 bytes. UTF-16 uses at most 4 bytes.
             Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` (Buffer Word8 -> Int
forall e. Buffer e -> Int
bufferAvailable Buffer Word8
obuf Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) -- In the best case, each pair of UTF-16 points fits into only 1 byte
    Buffer CWchar
mbuf <- Int -> Int -> BufferState -> IO (Buffer CWchar)
forall e. Int -> Int -> BufferState -> IO (Buffer e)
newBuffer (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sz) Int
sz BufferState
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.
    (CodingProgress
why1, Buffer CharBufElem
ibuf', Buffer CWchar
mbuf') <- CodeBuffer CharBufElem CWchar
utf16_native_encode Buffer CharBufElem
ibuf Buffer CWchar
mbuf
#endif
    String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\ncpEncode " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer CWchar -> String
forall a. Buffer a -> String
summaryBuffer Buffer CWchar
mbuf' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer Word8 -> String
forall a. Buffer a -> String
summaryBuffer Buffer Word8
obuf
    (CodingProgress
why2, Int
target_utf16_count, Buffer CWchar
mbuf', Buffer Word8
obuf) <- CodeBuffer CWchar Word8
-> Buffer CWchar
-> Buffer Word8
-> IO (CodingProgress, Int, Buffer CWchar, Buffer Word8)
forall from to.
CodeBuffer from to
-> Buffer from
-> Buffer to
-> IO (CodingProgress, Int, Buffer from, Buffer to)
saner ((Ptr CWchar -> Int -> Ptr Word8 -> Int -> IO (Either Bool Int))
-> (CWchar -> IO Bool)
-> Int
-> Int
-> Int
-> Int
-> CodeBuffer CWchar Word8
forall from to.
Storable from =>
(Ptr from -> Int -> Ptr to -> Int -> IO (Either Bool Int))
-> (from -> IO Bool)
-> Int
-> Int
-> Int
-> Int
-> CodeBuffer from to
cpRecode Ptr CWchar -> Int -> Ptr Word8 -> Int -> IO (Either Bool Int)
forall {a} {a} {b}.
(Integral a, Integral a, Show a, Show a, Num b) =>
Ptr CWchar -> a -> Ptr Word8 -> a -> IO (Either Bool b)
try' CWchar -> IO Bool
forall {m :: * -> *} {p}. Monad m => p -> m Bool
is_valid_prefix Int
2 Int
1 Int
1 Int
0) (Buffer CWchar
mbuf' { bufState = ReadBuffer }) Buffer Word8
obuf
    String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"cpRecode (cpEncode) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CodingProgress -> String
forall a. Show a => a -> String
show CodingProgress
why2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer CWchar -> String
forall a. Buffer a -> String
summaryBuffer Buffer CWchar
mbuf' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer Word8 -> String
forall a. Buffer a -> String
summaryBuffer Buffer Word8
obuf
#if defined(CHARBUF_UTF16)
    return (why2, mbuf', obuf)
#else
    case CodingProgress
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
      CodingProgress
InputUnderflow | Buffer CWchar -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer Buffer CWchar
mbuf' -> (CodingProgress, Buffer CharBufElem, Buffer Word8)
-> IO (CodingProgress, Buffer CharBufElem, Buffer Word8)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CodingProgress
why1, Buffer CharBufElem
ibuf', Buffer Word8
obuf)
                     | Bool
otherwise           -> String -> IO (CodingProgress, Buffer CharBufElem, Buffer Word8)
forall a. String -> a
errorWithoutStackTrace String
"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.
      CodingProgress
_ -> 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).
        Int
utf32_count <- String
-> CodeBuffer CharBufElem CWchar
-> Buffer CharBufElem
-> Buffer CWchar
-> Int
-> Int
-> Int
-> Int
-> IO Int
forall from to.
String
-> CodeBuffer from to
-> Buffer from
-> Buffer to
-> Int
-> Int
-> Int
-> Int
-> IO Int
bSearch String
"cpEncode" CodeBuffer CharBufElem CWchar
utf16_native_encode Buffer CharBufElem
ibuf Buffer CWchar
mbuf Int
target_utf16_count (Int
target_utf16_count Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int
target_utf16_count Int
target_utf16_count
        (CodingProgress, Buffer CharBufElem, Buffer Word8)
-> IO (CodingProgress, Buffer CharBufElem, Buffer Word8)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CodingProgress
why2, Int -> Buffer CharBufElem -> Buffer CharBufElem
forall e. Int -> Buffer e -> Buffer e
bufferRemove Int
utf32_count Buffer CharBufElem
ibuf, Buffer Word8
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 :: p -> m Bool
is_valid_prefix p
_ = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    try' :: Ptr CWchar -> a -> Ptr Word8 -> a -> IO (Either Bool b)
try' Ptr CWchar
iptr a
icnt Ptr Word8
optr a
ocnt
     -- WideCharToMultiByte does surprising things if you call it with ocnt == 0
     | a
ocnt a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = Either Bool b -> IO (Either Bool b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Either Bool b
forall a b. a -> Either a b
Left Bool
True)
     | Bool
otherwise = (Ptr Bool -> IO (Either Bool b)) -> IO (Either Bool b)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Bool -> IO (Either Bool b)) -> IO (Either Bool b))
-> (Ptr Bool -> IO (Either Bool b)) -> IO (Either Bool b)
forall a b. (a -> b) -> a -> b
$ \Ptr Bool
defaulted_ptr -> do
      Ptr Bool -> Bool -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Bool
defaulted_ptr Bool
False
      CInt
err <- Word32
-> Word32
-> Ptr CWchar
-> CInt
-> Ptr Word8
-> CInt
-> Ptr Word8
-> Ptr Bool
-> IO CInt
c_WideCharToMultiByte (Word32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
cp) Word32
0 -- NB: the WC_ERR_INVALID_CHARS flag is useless: only has an effect with the UTF-8 code page
                                   Ptr CWchar
iptr (a -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
icnt) Ptr Word8
optr (a -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
ocnt)
                                   Ptr Word8
forall a. Ptr a
nullPtr Ptr Bool
defaulted_ptr
      Bool
defaulted <- Ptr Bool -> IO Bool
forall a. Storable a => Ptr a -> IO a
peek Ptr Bool
defaulted_ptr
      String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"WideCharToMultiByte " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
cp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 0 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ptr CWchar -> String
forall a. Show a => a -> String
show Ptr CWchar
iptr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
icnt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ptr Word8 -> String
forall a. Show a => a -> String
show Ptr Word8
optr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
ocnt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" NULL " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ptr Bool -> String
forall a. Show a => a -> String
show Ptr Bool
defaulted_ptr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
defaulted
      case CInt
err of
          -- 0 indicates that we did not succeed
          CInt
0 -> do
            Word32
err <- IO Word32
getLastError
            case Word32
err of
                Word32
122  -> Either Bool b -> IO (Either Bool b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Either Bool b
forall a b. a -> Either a b
Left Bool
True)
                Word32
1113 -> Either Bool b -> IO (Either Bool b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Either Bool b
forall a b. a -> Either a b
Left Bool
False)
                Word32
_    -> String -> Word32 -> IO (Either Bool b)
forall a. String -> Word32 -> IO a
failWith String
"WideCharToMultiByte" Word32
err
          CInt
wrote_bytes | Bool
defaulted -> Either Bool b -> IO (Either Bool b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Either Bool b
forall a b. a -> Either a b
Left Bool
False)
                      | Bool
otherwise -> Either Bool b -> IO (Either Bool b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Either Bool b
forall a b. b -> Either a b
Right (CInt -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
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 :: forall from to.
String
-> CodeBuffer from to
-> Buffer from
-> Buffer to
-> Int
-> Int
-> Int
-> Int
-> IO Int
bSearch String
msg CodeBuffer from to
code Buffer from
ibuf Buffer to
mbuf Int
target_to_elems = Int -> Int -> Int -> IO Int
go
  where
    go :: Int -> Int -> Int -> IO Int
go Int
mn Int
md Int
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.
      (CodingProgress
_why, Buffer from
ibuf, Buffer to
mbuf) <- CodeBuffer from to
code (Buffer from
ibuf { bufR = bufL ibuf + md }) Buffer to
mbuf
      String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"code (bSearch " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
md String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CodingProgress -> String
forall a. Show a => a -> String
show CodingProgress
_why String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer from -> String
forall a. Buffer a -> String
summaryBuffer Buffer from
ibuf String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer to -> String
forall a. Buffer a -> String
summaryBuffer Buffer to
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 Buffer to -> Int
forall e. Buffer e -> Int
bufferElems Buffer to
mbuf Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Int
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:
        Ordering
EQ -> String -> IO ()
debugIO (String
"bSearch = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
solution) IO () -> IO Int -> IO Int
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
solution
          where solution :: Int
solution = Int
md Int -> Int -> Int
forall a. Num a => a -> a -> a
- Buffer from -> Int
forall e. Buffer e -> Int
bufferElems Buffer from
ibuf
        -- If we encoded fewer "to" characters than the target number, try again with more "from" characters (and vice-versa)
        Ordering
LT -> Int -> Int -> IO Int
go' (Int
mdInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
mx
        Ordering
GT -> Int -> Int -> IO Int
go' Int
mn (Int
mdInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    go' :: Int -> Int -> IO Int
go' Int
mn Int
mx | Int
mn Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
mx  = Int -> Int -> Int -> IO Int
go Int
mn (Int
mn Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ((Int
mx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
mn) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)) Int
mx
              | Bool
otherwise = String -> IO Int
forall a. String -> a
errorWithoutStackTrace (String -> IO Int) -> String -> IO Int
forall a b. (a -> b) -> a -> b
$ String
"bSearch(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"): search crossed! " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String, String, Int, Int, Int) -> String
forall a. Show a => a -> String
show (Buffer from -> String
forall a. Buffer a -> String
summaryBuffer Buffer from
ibuf, Buffer to -> String
forall a. Buffer a -> String
summaryBuffer Buffer to
mbuf, Int
target_to_elems, Int
mn, Int
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 :: forall from to.
Storable from =>
(Ptr from -> Int -> Ptr to -> Int -> IO (Either Bool Int))
-> (from -> IO Bool)
-> Int
-> Int
-> Int
-> Int
-> CodeBuffer from to
cpRecode Ptr from -> Int -> Ptr to -> Int -> IO (Either Bool Int)
try' from -> IO Bool
is_valid_prefix Int
max_i_size Int
min_o_size Int
iscale Int
oscale = CodeBuffer from to
go
  where
    go :: CodeBuffer from to
    go :: CodeBuffer from to
go Buffer from
ibuf Buffer to
obuf | Buffer from -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer Buffer from
ibuf                = (CodingProgress, Buffer from, Buffer to)
-> IO (CodingProgress, Buffer from, Buffer to)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CodingProgress
InputUnderflow,  Buffer from
ibuf, Buffer to
obuf)
                 | Buffer to -> Int
forall e. Buffer e -> Int
bufferAvailable Buffer to
obuf Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
min_o_size = (CodingProgress, Buffer from, Buffer to)
-> IO (CodingProgress, Buffer from, Buffer to)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CodingProgress
OutputUnderflow, Buffer from
ibuf, Buffer to
obuf)
                 | Bool
otherwise                         = Int
-> (Int -> Bool -> IO (CodingProgress, Buffer from, Buffer to))
-> IO (CodingProgress, Buffer from, Buffer to)
try (Buffer from -> Int
forall e. Buffer e -> Int
bufferElems Buffer from
ibuf Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` ((Int
max_i_size Int -> Int -> Int
forall a. Num a => a -> a -> a
* Buffer to -> Int
forall e. Buffer e -> Int
bufferAvailable Buffer to
obuf) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
min_o_size)) Int -> Bool -> IO (CodingProgress, Buffer from, Buffer to)
seek_smaller
      where
        done :: a -> m (a, Buffer from, Buffer to)
done a
why = (a, Buffer from, Buffer to) -> m (a, Buffer from, Buffer to)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
why, Buffer from
ibuf, Buffer to
obuf)

        seek_smaller :: Int -> Bool -> IO (CodingProgress, Buffer from, Buffer to)
seek_smaller Int
n Bool
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...
          | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 = if Bool
longer_was_valid
                      -- try m (where m >= n) was valid but we overflowed the output buffer with even a single input element
                      then CodingProgress -> IO (CodingProgress, Buffer from, Buffer to)
forall {m :: * -> *} {a}.
Monad m =>
a -> m (a, Buffer from, Buffer to)
done CodingProgress
OutputUnderflow
                      -- there was no initial valid sequence in the input, but it might just be a truncated buffer - we need to check
                      else do from
byte <- Buffer from -> (Ptr from -> IO from) -> IO from
forall e a. Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer Buffer from
ibuf ((Ptr from -> IO from) -> IO from)
-> (Ptr from -> IO from) -> IO from
forall a b. (a -> b) -> a -> b
$ \Ptr from
ptr -> Ptr from -> Int -> IO from
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr from
ptr (Buffer from -> Int
forall e. Buffer e -> Int
bufL Buffer from
ibuf)
                              Bool
valid_prefix <- from -> IO Bool
is_valid_prefix from
byte
                              CodingProgress -> IO (CodingProgress, Buffer from, Buffer to)
forall {m :: * -> *} {a}.
Monad m =>
a -> m (a, Buffer from, Buffer to)
done (if Bool
valid_prefix Bool -> Bool -> Bool
&& Buffer from -> Int
forall e. Buffer e -> Int
bufferElems Buffer from
ibuf Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
max_i_size then CodingProgress
InputUnderflow else CodingProgress
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.
          | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
max_i_size = Int
-> (Int -> Bool -> IO (CodingProgress, Buffer from, Buffer to))
-> IO (CodingProgress, Buffer from, Buffer to)
try (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (\Int
pred_n Bool
pred_n_was_valid -> Int -> Bool -> IO (CodingProgress, Buffer from, Buffer to)
seek_smaller Int
pred_n (Bool
longer_was_valid Bool -> Bool -> Bool
|| Bool
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' :: Int
n' = Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 = Int
-> (Int -> Bool -> IO (CodingProgress, Buffer from, Buffer to))
-> IO (CodingProgress, Buffer from, Buffer to)
try Int
n' (Int
-> Bool
-> Int
-> Bool
-> IO (CodingProgress, Buffer from, Buffer to)
post_divide Int
n' Bool
longer_was_valid)

        post_divide :: Int
-> Bool
-> Int
-> Bool
-> IO (CodingProgress, Buffer from, Buffer to)
post_divide Int
_  Bool
_                Int
n Bool
True  = Int -> Bool -> IO (CodingProgress, Buffer from, Buffer to)
seek_smaller Int
n Bool
True
        post_divide Int
n' Bool
longer_was_valid Int
n Bool
False | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
max_i_size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 = Int
-> (Int -> Bool -> IO (CodingProgress, Buffer from, Buffer to))
-> IO (CodingProgress, Buffer from, Buffer to)
try (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
-> Bool
-> Int
-> Bool
-> IO (CodingProgress, Buffer from, Buffer to)
post_divide Int
n' Bool
longer_was_valid) -- There's still a chance..
                                                | Bool
otherwise               = Int -> Bool -> IO (CodingProgress, Buffer from, Buffer to)
seek_smaller Int
n' Bool
longer_was_valid              -- No amount of recovery could save us :(

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

#endif