{-# LANGUAGE CPP #-}
{- |
   Module      :  System.Win32.Encoding
   Copyright   :  2012 shelarcy
   License     :  BSD-style

   Maintainer  :  shelarcy@gmail.com
   Stability   :  Provisional
   Portability :  Non-portable (Win32 API)

   Enocode/Decode mutibyte charactor using Win32 API.
-}

module System.Win32.Encoding
  ( getCurrentCodePage
  , encodeMultiByte
  , encodeMultiByteIO
  , decodeMultiByte
  , decodeMultiByteIO
  , wideCharToMultiByte
  , multiByteToWideChar
  ) where

import Foreign.C.Types        (CInt(..))
import Foreign.C.String       (peekCAStringLen, withCWStringLen)
import Foreign.Marshal.Array  (allocaArray)
import Foreign.Marshal.Unsafe (unsafeLocalState)
import System.Win32.Console
import System.Win32.NLS
import System.Win32.Types

#include "windows_cconv.h"

-- note CodePage = UInt which might not work on Win64.  But the Win32 package

-- also has this issue.

getCurrentCodePage :: IO DWORD
getCurrentCodePage :: IO DWORD
getCurrentCodePage = do
    DWORD
conCP <- IO DWORD
getConsoleCP
    if DWORD
conCP DWORD -> DWORD -> Bool
forall a. Ord a => a -> a -> Bool
> DWORD
0
        then DWORD -> IO DWORD
forall (m :: * -> *) a. Monad m => a -> m a
return DWORD
conCP
        else IO DWORD
getACP

-- | 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 :: DWORD -> String -> String
encodeMultiByte DWORD
cp = IO String -> String
forall a. IO a -> a
unsafeLocalState (IO String -> String) -> (String -> IO String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DWORD -> String -> IO String
encodeMultiByteIO DWORD
cp

encodeMultiByteIO :: CodePage -> String -> IO String
encodeMultiByteIO :: DWORD -> String -> IO String
encodeMultiByteIO DWORD
_ String
"" = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
  -- WideCharToMultiByte doesn't handle empty strings

encodeMultiByteIO DWORD
cp String
wstr =
  String -> (CWStringLen -> IO String) -> IO String
forall a. String -> (CWStringLen -> IO a) -> IO a
withCWStringLen String
wstr ((CWStringLen -> IO String) -> IO String)
-> (CWStringLen -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \(Ptr CWchar
cwstr,Int
len) -> do
    CInt
mbchars' <- String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
failIfZero String
"WideCharToMultiByte" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ DWORD
-> DWORD
-> Ptr CWchar
-> CInt
-> LPSTR
-> CInt
-> LPSTR
-> LPBOOL
-> IO CInt
wideCharToMultiByte 
                DWORD
cp
                DWORD
0
                Ptr CWchar
cwstr
                (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
                LPSTR
forall a. Ptr a
nullPtr CInt
0
                LPSTR
forall a. Ptr a
nullPtr LPBOOL
forall a. Ptr a
nullPtr
    -- mbchar' is the length of buffer required

    Int -> (LPSTR -> IO String) -> IO String
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
mbchars') ((LPSTR -> IO String) -> IO String)
-> (LPSTR -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \LPSTR
mbstr -> do
      CInt
mbchars <- String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
failIfZero String
"WideCharToMultiByte" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ DWORD
-> DWORD
-> Ptr CWchar
-> CInt
-> LPSTR
-> CInt
-> LPSTR
-> LPBOOL
-> IO CInt
wideCharToMultiByte 
                 DWORD
cp
                 DWORD
0
                 Ptr CWchar
cwstr
                 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
                 LPSTR
mbstr CInt
mbchars'
                 LPSTR
forall a. Ptr a
nullPtr LPBOOL
forall a. Ptr a
nullPtr
      CStringLen -> IO String
peekCAStringLen (LPSTR
mbstr,CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
mbchars)  -- converts [Char] to UTF-16


foreign import WINDOWS_CCONV "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 `getCurrentCodePage`.

decodeMultiByte :: CodePage -> String -> String
decodeMultiByte :: DWORD -> String -> String
decodeMultiByte DWORD
cp = IO String -> String
forall a. IO a -> a
unsafeLocalState (IO String -> String) -> (String -> IO String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DWORD -> String -> IO String
decodeMultiByteIO DWORD
cp

-- | Because of `stringToUnicode` is unclear name, we use `decodeMultiByteIO`

-- for alias of `stringToUnicode`. 

decodeMultiByteIO :: CodePage -> String -> IO String
decodeMultiByteIO :: DWORD -> String -> IO String
decodeMultiByteIO = DWORD -> String -> IO String
stringToUnicode
{-# INLINE decodeMultiByteIO #-}