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

Question

在Windows下的Haskell中使用控制台I/O来处理Unicode字符似乎相当困难.这是悲惨的故事:

1. (初步.)在您考虑在Windows下的控制台中进行Unicode I/O之前,您需要确保使用可以呈现所需字符的控制台字体.光栅字体(默认)具有无限的覆盖范围(并且不允许复制粘贴它们无法表示的字符),并且MS提供的truetype选项(consolas,lucida console)具有不太大的覆盖范围(尽管这些将允许复制/粘贴他们无法代表的字符).您可以考虑安装DejaVu Sans Mono(按照此处底部的说明进行操作;您可能必须在它运行之前重新启动).在对此进行排序之前,没有任何应用程序能够执行多少Unicode I/O; 不仅仅是哈斯克尔.
2. 完成此操作后,您会注意到某些应用程序将能够在Windows下执行控制台I/O. 但让它发挥作用仍然非常复杂.基本上有两种方法可以在windows下写入控制台.(对于任何语言都是如此,不仅仅是Haskell;不要担心,Haskell会稍微进入图片!)......
3. 选项A是使用通常的c库样式基于字节的i/o函数; 希望操作系统能够根据某些编码来解释这些字节,这些编码可以编码您想要的所有奇怪和精彩的字符.例如,在Mac OS X上使用等效技术,标准系统编码通常是UTF8,这很好用; 你发出utf8输出,你会看到漂亮的符号.
4. 在Windows上,它的效果不太好.Windows期望的默认编码通常不是涵盖所有Unicode符号的编码.因此,如果您希望以这种方式看到漂亮的符号,您需要更改编码.一种可能性是您的程序使用SetConsoleCPwin32命令.(那么你需要绑定到Win32库.)或者,如果您不想这样做,您可以期望程序的用户为您更改代码页(然后他们必须chcp在运行您之前调用命令程序).
5. 选项B是使用支持Unicode的win32控制台API命令WriteConsoleW.在这里,您可以直接向窗口发送UTF16,这使得它很愉快:没有编码不匹配的危险,因为Windows 总是希望UTF16具有这些功能.

不幸的是,这些选项都不适用于Haskell.首先,我知道没有使用选项B的库,所以这并不容易.这留下了选项A.如果你使用Haskell的I/O库(putStrLn等等),这就是库的功能.在现代版本的Haskell中,它会仔细询问windows当前代码页是什么,并以正确的编码输出字符串.这种方法存在两个问题:

• 一个不是一个showstopper,但很烦人.如上所述,默认编码几乎不会编码您想要的字符:您是用户需要更改为编码的编码.因此,您的用户需要chcp cp65001在他们运行您的程序之前(您可能会发现强迫您的用户执行此操作令人反感).或者你需要绑定SetConsoleCP并在程序中执行等效操作(然后使用hSetEncoding以便Haskell库使用新编码发送输出),这意味着你需要包装win32库的相关部分以使它们可见Haskell .
• 更严重的是,Windows中存在一个错误(解决方案:无法修复)导致Haskell中的错误,这意味着如果您选择了可以覆盖所有Unicode的任何代码页,如cp65001,Haskell的I/O例程将故障和失败.所以基本上,即使你(或你的用户)正确地将编码设置为覆盖所有精彩Unicode字符的某些编码,然后在"告诉Haskell使用该编码输出内容时做一切正确",你仍然会丢失.

上面列出的错误仍未解决,并列为低优先级; 基本结论是选项A(在我上面的分类中)是不可行的,需要切换到选项B以获得可靠的结果.目前尚不清楚解决这个问题的时间表是什么,因为它看起来像是一些相当大的工作.

问题是:与此同时,任何人都可以建议一种解决方法,允许在Windows下的Haskell中使用Unicode控制台I/O.

另请参阅此python错误跟踪器数据库条目,解决Python 3中的相同问题(已提出修复,但尚未被接受到代码库中),以及此stackoverflow答案,为Python中的此问题提供了一种解决方法(基于'选项B'在我的分类中).

Answer 1

我想我会回答我自己的问题,并列出一个可能的答案,以下,这就是我此刻正在做的事情.人们很可能会做得更好,这就是我提出这个问题的原因!但我认为让人们可以使用以下内容是有意义的.对于同样的问题,它基本上是从Python到Haskell的这个python解决方法的翻译.它使用问题中提到的"选项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函数,并使用支持WriteConsoleWunicode的win32控制台函数直接写入win32控制台.在非Windows平台上,条件编译意味着这里的函数只调用标准库函数.

如果你需要打印到stderr,你应该使用(例如)ePutStrLn,而不是hPutStrLn stderr; 我们没有定义hPutStrLn.(定义一个是读者的练习!)