如何在用户输入时“抑制”主线程并发的“永远运行”操作？

Question

这个节目

{-# LANGUAGE LambdaCase #-}
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (withAsync)
import Control.Exception (finally)
import Control.Monad (forever)

main :: IO ()
main = do
  let as = [(forever $ wait1sec >> putStrLn "hello 0") `finally` putStrLn "bye 0",
            (forever $ wait1sec >> putStrLn "hello 1") `finally` putStrLn "bye 1",
            (forever $ wait1sec >> putStrLn "hello 2") `finally` putStrLn "bye 2"]
  foldr (\a b -> withAsync a (const b))
        (forever $ do wait1sec >> putStrLn "hellooo")
        as
  where
    wait1sec = threadDelay 1000000

每秒打印这 4 行的随机排列

hello 0
hello 1
hello 2
hellooo

并且，当程序终止时（显然，唯一的问题就是杀死它），它也会打印

bye 2
bye 1
bye 0

（我总是按这个顺序看到输出，我猜是因为这是列表条目被销毁的顺序？）

现在，假设我希望程序的主线程（打印

hellooo

的线程）从键盘获取输入，并基于此“杀死”

as

中的条目之一（这将导致它

 bye

待打印）。我该怎么办？

---

我想只要

as

是不可变的，就没有办法实现这一点，所以第一步可能是为其创建一个

IORef

。这肯定会给我一种从主线程内部更改列表的方法，就像这样

-- assuming asr is an IORef [IO Any]
        (forever $ do wait1sec >> putStrLn "gimme a number"
                      getChar >>= \case
                                    '0' -> atomicModifyIORef' asr (\a -> (tail a, ()))
                                    '1' -> atomicModifyIORef' asr (\a -> ([head a, last a], ()))
                                    '2' -> atomicModifyIORef' asr (\a -> (init a, ()))
                                    _ -> return ())

但这基本上没有效果，因为

foldr

已经产生了3个并发操作（我仍然必须将列表传递给它，所以

as

，而不是

asr

），它不会关心会发生什么

asr

，对吧？

我开始思考，除非我建立某种机制，让

forever

并不真正意味着“永远”，否则我没有机会。

Answer 1

实际上，当我输入问题时，我的一个旧问题和已接受的答案一起浮现在脑海中：

MaybeT

是人们可以将

forever

变成

runMaybeT . forever

以获得某些东西的一种方法可以通过

mzero

中断。

这是我的问题的可能解决方案：

{-# LANGUAGE LambdaCase #-}
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (withAsync)
import Control.Exception (finally)
import Control.Monad (forever, mzero)
import Control.Monad.Trans.Maybe (runMaybeT)
import Control.Monad.IO.Class (liftIO)
import Data.IORef (atomicModifyIORef', newIORef, readIORef)
import System.IO (hSetBuffering, stdin, BufferMode(NoBuffering))

main :: IO ()
main = do
  hSetBuffering stdin NoBuffering
  flag <- newIORef '-'
  let as = [((runMaybeT . forever) $ wait1sec' >> (putStrLn' "hello 0") >> stop flag '0')
                `finally` putStrLn "bye 0",
            ((runMaybeT . forever) $ wait1sec' >> (putStrLn' "hello 1") >> stop flag '1')
                `finally` putStrLn "bye 1",
            ((runMaybeT . forever) $ wait1sec' >> (putStrLn' "hello 2") >> stop flag '2')
                `finally` putStrLn "bye 2"]
  foldr (\a b -> withAsync a (const b))
        (forever $ do wait1sec >> putStrLn "gimme a number"
                      getChar >>= \c -> atomicModifyIORef' flag (\_ -> (c, ())))
        as
  where
    wait1sec = threadDelay 1000000
    wait1sec' = liftIO wait1sec
    putStrLn' = liftIO . putStrLn
    stop f i = do
      j <- liftIO $ readIORef f
      if j == i
        then mzero
        else return ()