content: {-# LANGUAGE CPP                  #-}
  {-# LANGUAGE NoImplicitPrelude    #-}
  {- |
     Module      :  System.Win32.Encoding
     Copyright   :  2012 shelarcy
     License     :  BSD-style
  
     Maintainer  :  shelarcy@gmail.com
     Stability   :  Provisional
     Portability :  Non-portable (Win32 API)
  
     Encode/Decode multibyte character using Win32 API.
  -}
  
  module GHC.Internal.IO.Windows.Encoding
    ( encodeMultiByte
    , encodeMultiByteIO
    , encodeMultiByteRawIO
    , decodeMultiByte
    , decodeMultiByteIO
    , wideCharToMultiByte
    , multiByteToWideChar
    , withGhcInternalToUTF16
    , withUTF16ToGhcInternal
    ) where
  
  import GHC.Internal.Word (Word8, Word16)
  import GHC.Internal.Foreign.C.Types        (CInt(..))
  import GHC.Internal.Foreign.C.String       (peekCAStringLen, peekCWStringLen,
                                 withCWStringLen, withCAStringLen, )
  import GHC.Internal.Foreign.Ptr (nullPtr, Ptr ())
  import GHC.Internal.Foreign.Marshal.Array  (allocaArray)
  import GHC.Internal.Foreign.Marshal.Unsafe (unsafeLocalState)
  import GHC.Internal.Windows
  import GHC.Internal.IO.Encoding.CodePage (CodePage, getCurrentCodePage)
  import GHC.Internal.IO
  import GHC.Internal.Base
  import GHC.Internal.Real
  
  -- | The "System.IO" output functions (e.g. `putStr`) don't
  -- automatically convert to multibyte string on Windows, so this
  -- function is provided to make the conversion from a Unicode string
  -- in the given code page to a proper multibyte string.  To get the
  -- code page for the console, use `getCurrentCodePage`.
  --
  encodeMultiByte :: CodePage -> String -> String
  encodeMultiByte cp = unsafeLocalState . encodeMultiByteIO cp
  
  {-# INLINE encodeMultiByteIO' #-}
  -- | String must not be zero length.
  encodeMultiByteIO' :: CodePage -> String -> ((LPCSTR, CInt) -> IO a) -> IO a
  encodeMultiByteIO' cp wstr transformer =
    withCWStringLen wstr $ \(cwstr,len) -> do
      mbchars' <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte
                  cp
                  0
                  cwstr
                  (fromIntegral len)
                  nullPtr 0
                  nullPtr nullPtr
      -- mbchar' is the length of buffer required
      allocaArray (fromIntegral mbchars') $ \mbstr -> do
        mbchars <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte
                   cp
                   0
                   cwstr
                   (fromIntegral len)
                   mbstr mbchars'
                   nullPtr nullPtr
        transformer (mbstr,fromIntegral mbchars)
  
  -- converts [Char] to UTF-16
  encodeMultiByteIO :: CodePage -> String -> IO String
  encodeMultiByteIO _ "" = return ""
  encodeMultiByteIO cp s = encodeMultiByteIO' cp s toString
    where toString (st,l) = peekCAStringLen (st,fromIntegral l)
  
  -- converts [Char] to UTF-16
  encodeMultiByteRawIO :: CodePage -> String -> IO (LPCSTR, CInt)
  encodeMultiByteRawIO _ "" = return (nullPtr, 0)
  encodeMultiByteRawIO cp s = encodeMultiByteIO' cp s toSizedCString
    where toSizedCString (st,l) = return (st, fromIntegral l)
  
  foreign import ccall "WideCharToMultiByte"
    wideCharToMultiByte
          :: CodePage
          -> DWORD   -- dwFlags,
          -> LPCWSTR -- lpWideCharStr
          -> CInt    -- cchWideChar
          -> LPSTR   -- lpMultiByteStr
          -> CInt    -- cbMultiByte
          -> LPCSTR  -- lpMultiByteStr
          -> LPBOOL  -- lpbFlags
          -> IO CInt
  
  -- | The `System.IO` input functions (e.g. `getLine`) don't
  -- automatically convert to Unicode, so this function is provided to
  -- make the conversion from a multibyte string in the given code page
  -- to a proper Unicode string.  To get the code page for the console,
  -- use `getConsoleCP`.
  stringToUnicode :: CodePage -> String -> IO String
  stringToUnicode _cp "" = return ""
       -- MultiByteToWideChar doesn't handle empty strings (#1929)
  stringToUnicode cp mbstr =
    withCAStringLen mbstr $ \(cstr,len) -> do
      wchars <- failIfZero "MultiByteToWideChar" $ multiByteToWideChar
                  cp
                  0
                  cstr
                  (fromIntegral len)
                  nullPtr 0
      -- wchars is the length of buffer required
      allocaArray (fromIntegral wchars) $ \cwstr -> do
        wchars' <- failIfZero "MultiByteToWideChar" $ multiByteToWideChar
                  cp
                  0
                  cstr
                  (fromIntegral len)
                  cwstr wchars
        peekCWStringLen (cwstr,fromIntegral wchars')  -- converts UTF-16 to [Char]
  
  foreign import ccall unsafe "MultiByteToWideChar"
    multiByteToWideChar
          :: CodePage
          -> DWORD   -- dwFlags,
          -> LPCSTR  -- lpMultiByteStr
          -> CInt    -- cbMultiByte
          -> LPWSTR  -- lpWideCharStr
          -> CInt    -- cchWideChar
          -> IO CInt
  
  decodeMultiByte :: CodePage -> String -> String
  decodeMultiByte cp = unsafeLocalState . decodeMultiByteIO cp
  
  -- | Because of `stringToUnicode` is unclear name, we use `decodeMultiByteIO`
  -- for alias of `stringToUnicode`.
  decodeMultiByteIO :: CodePage -> String -> IO String
  decodeMultiByteIO = stringToUnicode
  {-# INLINE decodeMultiByteIO #-}
  
  foreign import ccall unsafe "MultiByteToWideChar"
    multiByteToWideChar'
          :: CodePage
          -> DWORD   -- dwFlags,
          -> Ptr Word8  -- lpMultiByteStr
          -> CInt    -- cbMultiByte
          -> Ptr Word16  -- lpWideCharStr
          -> CInt    -- cchWideChar
          -> IO CInt
  
  -- TODO: GHC is internally UTF-32 which means we have re-encode for
  --       Windows which is annoying. Switch to UTF-16 on IoNative
  --       being default.
  withGhcInternalToUTF16 :: Ptr Word8 -> Int -> ((Ptr Word16, CInt) -> IO a)
                         -> IO a
  withGhcInternalToUTF16 ptr len fn
   = do cp <- getCurrentCodePage
        wchars <- failIfZero "withGhcInternalToUTF16" $
                    multiByteToWideChar' cp 0 ptr (fromIntegral len) nullPtr 0
        -- wchars is the length of buffer required
        allocaArray (fromIntegral wchars) $ \cwstr -> do
          wchars' <- failIfZero "withGhcInternalToUTF16" $
                      multiByteToWideChar' cp 0 ptr (fromIntegral len) cwstr wchars
          fn (cwstr, wchars')
  
  foreign import ccall "WideCharToMultiByte"
    wideCharToMultiByte'
          :: CodePage
          -> DWORD   -- dwFlags,
          -> Ptr Word16 -- lpWideCharStr
          -> CInt    -- cchWideChar
          -> Ptr Word8   -- lpMultiByteStr
          -> CInt    -- cbMultiByte
          -> LPCSTR  -- lpMultiByteStr
          -> LPBOOL  -- lpbFlags
          -> IO CInt
  
  -- TODO: GHC is internally UTF-32 which means we have re-encode for
  --       Windows which is annoying. Switch to UTF-16 on IoNative
  --       being default.
  
  -- | Decode a UTF16 buffer into the given buffer in the current code page.
  -- The source UTF16 buffer is filled by the function given as argument.
  withUTF16ToGhcInternal :: Ptr Word8 -- Buffer to store the encoded string in.
                         -> Int       -- Length of the buffer
                         -- Function to fill source buffer.
                         ->  ( CInt       -- Size of available buffer in bytes
                            -> Ptr Word16 -- Temporary source buffer.
                            -> IO CInt    -- Actual length of buffer content.
                             )
                         -> IO Int    -- Returns number of bytes stored in buffer.
  withUTF16ToGhcInternal ptr len fn
   = do cp <- getCurrentCodePage
        -- Annoyingly the IO system is very UTF-32 oriented and asks for bytes
        -- as buffer reads.  Problem is we don't know how many bytes we'll end up
        -- having as UTF-32 MultiByte encoded UTF-16. So be conservative.  We assume
        -- that a single byte may expand to atmost 1 Word16.  So assume that each
        -- byte does and divide the requested number of bytes by two since each
        -- Word16 encoded wchar may expand to only two Word8 sequences.
        let reqBytes = fromIntegral (len `div` 2)
        allocaArray reqBytes $ \w_ptr -> do
          w_len <- fn (fromIntegral reqBytes) w_ptr
          if w_len == 0
             then return 0 else do
                  -- Get required length of encoding
                  mbchars' <- failIfZero "withUTF16ToGhcInternal" $
                                wideCharToMultiByte' cp 0 w_ptr
                                                    (fromIntegral w_len) nullPtr
                                                    0 nullPtr nullPtr
                  assert (mbchars' <= (fromIntegral len)) $ do
                    -- mbchar' is the length of buffer required
                    mbchars <- failIfZero "withUTF16ToGhcInternal" $
                                  wideCharToMultiByte' cp 0 w_ptr
                                                      (fromIntegral w_len) ptr
                                                      mbchars' nullPtr nullPtr
                    return $ fromIntegral mbchars
  