Windows 上 Haskell 中的 Unicode 控制台 I/O

在 Windows 下的 Haskell 中让控制台 I/O 与 Unicode 字符一起工作似乎相当困难。这是一个悲惨的故事：

1. （初步的。）在考虑在 Windows 下的控制台中执行 Unicode I/O 之前，您需要确保您使用的控制台字体可以呈现您想要的字符。光栅字体（默认）的覆盖范围非常差（并且不允许复制粘贴它们无法表示的字符），而 MS 提供的 TrueType 选项（Consolas、Lucida Console）的覆盖范围并不大（尽管这些将允许复制粘贴它们无法表示的字符）。您可以考虑安装 DejaVu Sans Mono（按照底部的说明进行操作）here https://stackoverflow.com/questions/878972/windows-cmd-encoding-change-causes-python-crash/3259271#3259271;您可能必须重新启动才能工作）。在此排序之前，任何应用程序都无法执行大量 Unicode I/O；不仅仅是哈斯克尔。
2. 完成此操作后，您会注意到某些应用程序将能够在 Windows 下执行控制台 I/O。但让它发挥作用仍然相当复杂。在 Windows 下基本上有两种写入控制台的方法。 （下面的内容适用于任何语言，而不仅仅是 Haskell；别担心，Haskell 稍后就会介绍！）...
3. 选项 A 是使用通常的 C 库风格的基于字节的 I/O 函数；希望操作系统能够根据某种编码来解释这些字节，这种编码可以编码您想要的所有奇怪而美妙的字符。例如，在 Mac OS X 上使用等效技术，其中标准系统编码通常是 UTF8，效果很好；你发送 UTF8 输出，你会看到漂亮的符号。
4. 在 Windows 上，它的效果不太好。 Windows 期望的默认编码通常不是涵盖所有 Unicode 符号的编码。因此，如果您想以这种方式看到漂亮的符号，那么您需要change编码。一种可能性是您的程序使用SetConsoleCPwin32命令。 （因此您需要绑定到 Win32 库。）或者，如果您不想这样做，您可以期望程序的用户为您更改代码页（然后他们必须调用chcp在他们运行你的程序之前命令）。
5. 选项 B 是使用支持 Unicode 的 win32 控制台 API 命令，例如WriteConsoleW。在这里，您将 UTF16 直接发送到 Windows，这会愉快地呈现它：不存在编码不匹配的危险，因为 Windowsalways这些函数需要 UTF16。

不幸的是，这些选项在 Haskell 中都不能很好地工作。首先，据我所知，没有任何库使用选项 B，所以这不是很容易。这就剩下选项 A。如果你使用 Haskell 的 I/O 库（putStrLn等等），这就是图书馆要做的。在现代版本的 Haskell 中，它会仔细询问 Windows 当前的代码页是什么，并以正确的编码输出字符串。这种方法有两个问题：

• 一个不是一个引人注目的人，但它很烦人。如上所述，默认编码几乎永远不会编码您想要的字符：您需要用户更改为可以编码的编码。因此您的用户需要chcp cp65001在他们运行你的程序之前（你可能会发现强迫你的用户这样做是令人厌恶的）。或者，您需要绑定到SetConsoleCP并在程序中执行等效操作（然后使用hSetEncoding这样 Haskell 库将使用新编码发送输出），这意味着您需要包装 win32 库的相关部分以使它们对 Haskell 可见。
• 更严重的是，有一个Windows 中的错误 https://web.archive.org/web/20130831062807/http://connect.microsoft.com/VisualStudio/feedback/details/543801/unicode-issues-with-writefile-and-in-the-crt（解决方案：不会修复）这会导致哈斯克尔中的错误 http://hackage.haskell.org/trac/ghc/ticket/4471这意味着，如果您选择了像 cp65001 这样可以覆盖所有 Unicode 的任何代码页，Haskell 的 I/O 例程将发生故障并失败。所以本质上，even if你（或你的用户）将编码正确设置为某种涵盖所有精彩 Unicode 字符的编码，然后“做对一切”告诉 Haskell 使用该编码输出内容，你仍然会失败。

上面列出的错误仍未解决，并被列为低优先级；基本结论是选项 A（在我上面的分类中）不可行，需要改用选项 B 才能获得可靠的结果。目前尚不清楚解决这个问题的时间表，因为这看起来是一项艰巨的工作。

问题是：同时，有人可以建议一种解决方法，以允许在 Windows 下的 Haskell 中使用 Unicode 控制台 I/O 吗？

另请参阅此Python 错误跟踪器数据库条目 http://bugs.python.org/issue1602，解决 Python 3 中的相同问题（已提出修复方案，但尚未被代码库接受），以及这个堆栈溢出答案 https://stackoverflow.com/questions/878972/windows-cmd-encoding-change-causes-python-crash/3259271#3259271，给出了 Python 中此问题的解决方法（基于我的分类中的“选项 B”）。

我想我会回答我自己的问题，并列出一种可能答案如下，这就是我目前正在实际做的事情。很有可能一个人可以做得更好，这就是我问这个问题的原因！但我认为向人们提供以下内容是有意义的。它基本上是从 Python 到 Haskell 的翻译python 解决同一问题的方法 https://stackoverflow.com/questions/878972/windows-cmd-encoding-change-causes-python-crash/3259271#3259271。它使用问题中提到的“选项 B”。

基本思想是创建一个模块 IOUtil.hs，其中包含以下内容，您可以import进入你的代码：

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
module IOUtil (
  IOUtil.interact,
  IOUtil.putChar, IOUtil.putStr, IOUtil.putStrLn, IOUtil.print,
  IOUtil.getChar, IOUtil.getLine, IOUtil.getContents, IOUtil.readIO,
  IOUtil.readLn,
  ePutChar, ePutStr, ePutStrLn, ePrint,
  trace, traceIO
  ) where

#ifdef mingw32_HOST_OS

import System.Win32.Types (BOOL, HANDLE, DWORD, LPDWORD, LPWSTR, LPCWSTR, LPVOID)
import Foreign.C.Types (CWchar)
import Foreign
import Prelude hiding (getContents, putStr, putStrLn) --(IO, Read, Show, String)
--import qualified System.IO
import qualified System.IO (getContents)
import System.IO hiding (getContents, putStr, putStrLn)
import Data.Char (ord)

 {- <http://msdn.microsoft.com/en-us/library/ms683231(VS.85).aspx>
    HANDLE WINAPI GetStdHandle(DWORD nStdHandle);
    returns INVALID_HANDLE_VALUE, NULL, or a valid handle -}

foreign import stdcall unsafe "GetStdHandle" win32GetStdHandle :: DWORD -> IO (HANDLE)

std_OUTPUT_HANDLE = -11 :: DWORD  -- all DWORD arithmetic is performed modulo 2^n
std_ERROR_HANDLE  = -12 :: DWORD

 {- <http://msdn.microsoft.com/en-us/library/aa364960(VS.85).aspx>
    DWORD WINAPI GetFileType(HANDLE hFile); -}

foreign import stdcall unsafe "GetFileType" win32GetFileType :: HANDLE -> IO (DWORD)
_FILE_TYPE_CHAR   = 0x0002 :: DWORD
_FILE_TYPE_REMOTE = 0x8000 :: DWORD

 {- <http://msdn.microsoft.com/en-us/library/ms683167(VS.85).aspx>
    BOOL WINAPI GetConsoleMode(HANDLE hConsole, LPDWORD lpMode); -}

foreign import stdcall unsafe "GetConsoleMode" win32GetConsoleMode :: HANDLE -> LPDWORD -> IO (BOOL)
_INVALID_HANDLE_VALUE = (intPtrToPtr $ -1) :: HANDLE

is_a_console :: HANDLE -> IO (Bool)
is_a_console handle
  = if (handle == _INVALID_HANDLE_VALUE) then return False
      else do ft <- win32GetFileType handle
              if ((ft .&. complement _FILE_TYPE_REMOTE) /= _FILE_TYPE_CHAR) then return False
                else do ptr <- malloc
                        cm  <- win32GetConsoleMode handle ptr
                        free ptr
                        return cm

real_stdout :: IO (Bool)
real_stdout = is_a_console =<< win32GetStdHandle std_OUTPUT_HANDLE

real_stderr :: IO (Bool)
real_stderr = is_a_console =<< win32GetStdHandle std_ERROR_HANDLE

 {- BOOL WINAPI WriteConsoleW(HANDLE hOutput, LPWSTR lpBuffer, DWORD nChars,
                              LPDWORD lpCharsWritten, LPVOID lpReserved); -}

foreign import stdcall unsafe "WriteConsoleW" win32WriteConsoleW
  :: HANDLE -> LPWSTR -> DWORD -> LPDWORD -> LPVOID -> IO (BOOL)

data ConsoleInfo = ConsoleInfo Int (Ptr CWchar) (Ptr DWORD) HANDLE

writeConsole :: ConsoleInfo -> [Char] -> IO ()
writeConsole (ConsoleInfo bufsize buf written handle) string
  = let fillbuf :: Int -> [Char] -> IO ()
        fillbuf i [] = emptybuf buf i []
        fillbuf i remain@(first:rest)
          | i + 1 < bufsize && ordf <= 0xffff = do pokeElemOff buf i asWord
                                                   fillbuf (i+1) rest
          | i + 1 < bufsize && ordf >  0xffff = do pokeElemOff buf i word1
                                                   pokeElemOff buf (i+1) word2
                                                   fillbuf (i+2) rest
          | otherwise                         = emptybuf buf i remain
          where ordf   = ord first
                asWord = fromInteger (toInteger ordf) :: CWchar
                sub    = ordf - 0x10000
                word1' = ((shiftR sub 10) .&. 0x3ff) + 0xD800
                word2' = (sub .&. 0x3FF)             + 0xDC00
                word1  = fromInteger . toInteger $ word1'
                word2  = fromInteger . toInteger $ word2'


        emptybuf :: (Ptr CWchar) -> Int -> [Char] -> IO ()
        emptybuf _ 0 []     = return ()
        emptybuf _ 0 remain = fillbuf 0 remain
        emptybuf ptr nLeft remain
          = do let nLeft'    = fromInteger . toInteger $ nLeft
               ret          <- win32WriteConsoleW handle ptr nLeft' written nullPtr
               nWritten     <- peek written
               let nWritten' = fromInteger . toInteger $ nWritten
               if ret && (nWritten > 0)
                  then emptybuf (ptr `plusPtr` (nWritten' * szWChar)) (nLeft - nWritten') remain
                  else fail "WriteConsoleW failed.\n"

    in  fillbuf 0 string

szWChar = sizeOf (0 :: CWchar)

makeConsoleInfo :: DWORD -> Handle -> IO (Either ConsoleInfo Handle)
makeConsoleInfo nStdHandle fallback
  = do handle     <- win32GetStdHandle nStdHandle
       is_console <- is_a_console handle
       let bufsize = 10000
       if not is_console then return $ Right fallback
         else do buf     <- mallocBytes (szWChar * bufsize)
                 written <- malloc
                 return . Left $ ConsoleInfo bufsize buf written handle

{-# NOINLINE stdoutConsoleInfo #-}
stdoutConsoleInfo :: Either ConsoleInfo Handle
stdoutConsoleInfo = unsafePerformIO $ makeConsoleInfo std_OUTPUT_HANDLE stdout

{-# NOINLINE stderrConsoleInfo #-}
stderrConsoleInfo :: Either ConsoleInfo Handle
stderrConsoleInfo = unsafePerformIO $ makeConsoleInfo std_ERROR_HANDLE stderr

interact     :: (String -> String) -> IO ()
interact f   = do s <- getContents
                  putStr (f s)

conPutChar ci  = writeConsole ci . replicate 1
conPutStr      = writeConsole
conPutStrLn ci = writeConsole ci . ( ++ "\n")

putChar      :: Char -> IO ()
putChar      = (either conPutChar  hPutChar ) stdoutConsoleInfo

putStr       :: String -> IO ()
putStr       = (either conPutStr   hPutStr  ) stdoutConsoleInfo

putStrLn     :: String -> IO ()
putStrLn     = (either conPutStrLn hPutStrLn) stdoutConsoleInfo

print        :: Show a => a -> IO ()
print        = putStrLn . show

getChar      = System.IO.getChar
getLine      = System.IO.getLine
getContents  = System.IO.getContents

readIO       :: Read a => String -> IO a
readIO       = System.IO.readIO

readLn       :: Read a => IO a
readLn       = System.IO.readLn

ePutChar     :: Char -> IO ()
ePutChar     = (either conPutChar  hPutChar ) stderrConsoleInfo

ePutStr     :: String -> IO ()
ePutStr      = (either conPutStr   hPutStr  ) stderrConsoleInfo

ePutStrLn   :: String -> IO ()
ePutStrLn    = (either conPutStrLn hPutStrLn) stderrConsoleInfo

ePrint       :: Show a => a -> IO ()
ePrint       = ePutStrLn . show

#else

import qualified System.IO
import Prelude (IO, Read, Show, String)

interact     = System.IO.interact
putChar      = System.IO.putChar
putStr       = System.IO.putStr
putStrLn     = System.IO.putStrLn
getChar      = System.IO.getChar
getLine      = System.IO.getLine
getContents  = System.IO.getContents
ePutChar     = System.IO.hPutChar System.IO.stderr
ePutStr      = System.IO.hPutStr System.IO.stderr
ePutStrLn    = System.IO.hPutStrLn System.IO.stderr

print        :: Show a => a -> IO ()
print        = System.IO.print

readIO       :: Read a => String -> IO a
readIO       = System.IO.readIO

readLn       :: Read a => IO a
readLn       = System.IO.readLn

ePrint       :: Show a => a -> IO ()
ePrint       = System.IO.hPrint System.IO.stderr

#endif

trace :: String -> a -> a
trace string expr = unsafePerformIO $ do
    traceIO string
    return expr

traceIO :: String -> IO ()
traceIO = ePutStrLn

然后，您可以使用其中包含的 I/O 函数而不是标准库函数。他们会检测输出是否被重定向；如果不是（即，如果我们正在写入“真实”控制台），那么我们将绕过通常的 Haskell I/O 函数并使用以下命令直接写入 win32 控制台WriteConsoleW，支持 unicode 的 win32 控制台函数。在非Windows平台上，条件编译意味着这里的函数只调用标准库的函数。

如果您需要打印到 stderr，您应该使用（例如）ePutStrLn, not hPutStrLn stderr;我们没有定义一个hPutStrLn。 （定义一个是读者的一项练习！）