haskell - 如何安全地中止 getChar？

Question

我想选择性地中止 getChar行动。我需要以下功能:

getChar' :: (Char -> IO ()) -> IO (IO ())

如果是abort <- getChar' callback ，从标准输入读取字符，除非 abort在角色可用之前调用。如果读取一个字符，callback用它来调用。

我有以下原型(prototype)实现:

import Control.Monad
import Control.Concurrent

getChar' :: (Char -> IO ()) -> IO (IO ())
getChar' callback = do
    v <- newEmptyMVar
    tid <- forkIO $ do
        c <- getChar
        b <- tryPutMVar v ()
        when b $ callback c
    return $ do
        b <- tryPutMVar v ()
        when b $ killThread tid

问题是 killThread可能会在读取字符后但在放置 () 之前中止线程进入 MVar。

我不知道如何解决这个问题，基础包有可能吗？如果没有，您是否在其他包中看到过类似的功能？

Answer 1

我认为实现此目的最简单的方法是执行您自己的缓冲。这是一个简单的原型(prototype)。它假设您在程序中只调用一次 launchIOThread 。它不处理 EOF 或其他 IO 异常，但这应该很容易。

import Control.Concurrent
import Control.Concurrent.STM
import Data.Maybe
import Control.Monad

type Buffer = TVar (Maybe Char)

launchIOThread :: IO Buffer
launchIOThread = do
  buf <- atomically $ newTVar Nothing
  _ <- forkIO $ ioThread buf
  return buf

ioThread :: Buffer -> IO ()
ioThread buf = loop where
  loop =
    join $ atomically $ do
      contents <- readTVar buf
      if isJust contents -- no-one has taken the character yet
        then retry -- relax
        else return $ do
          c <- getChar
          atomically $ writeTVar buf (Just c)
          loop

getChar' :: Buffer -> (Char -> IO ()) -> IO (IO ())
getChar' buf callback = do
  abortFlag <- atomically $ newTVar False

  _ <- forkIO $ doGetChar abortFlag

  return $ atomically $ writeTVar abortFlag True

  where
    doGetChar abortFlag = join $ atomically $ do
      mbC <- readTVar buf
      abort <- readTVar abortFlag
      case mbC of
        Just c ->
          do writeTVar buf Nothing; return $ callback c
        Nothing | abort -> return $ return ()
        _ -> retry