如何安全地中止getChar？

Question

我想选择中止一个getChar动作.我需要以下功能:

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

如果是abort <- getChar' callback,则从标准输入读取字符,除非abort在字符可用之前调用.如果读取了一个字符,callback则使用它进行调用.

我有以下原型实现:

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可能在读取char之后但在放入()MVar 之前中止线程.

我不知道如何解决这个问题,是否可以使用基础包？如果没有,你看到其他包中实现了类似的功能吗？

Answer 1

我认为实现这一点的最简单方法是执行您自己的缓冲。这是一个简单的原型。它假设您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