How to abort getChar safely?

Question

I would like to optionally abort a getChar action. I need the following function:

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

In case of abort <- getChar' callback , a character is read from standard input, unless abort is called before a character is available. If a character is read, callback is called with it.

I have the following prototype implementation:

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

The problem is that killThread may abort the thread after reading the char but before putting () into the MVar.

I have no idea how to solve this problem, is it possible at all with the base package? If not, have you seen a similar function implemented in other packages?

Answer 1

I think the easiest way to achieve this is to perform your own buffering. Here's a simple prototype. It assumes that you call launchIOThread exactly once in your program. It doesn't handle EOF or other IO exceptions, but that should be easy.

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