Haskell实现可随时退出、多次运行的计时器问题求助

• 解决SIGINT响应延迟问题：原实现中threadDelay是阻塞操作，必须等满1秒才会检查MVar状态。你可以把整秒等待拆分为多个短时间片轮询MVar，或是使用并发工具同时执行等待逻辑和MVar监听，一旦MVar有写入就立刻中断等待，响应延迟可控制在毫秒级。
• 解决连续SIGINT触发程序终止问题：原代码使用CatchOnce注册信号处理函数，第一次触发SIGINT后处理器就会被注销，第二次触发就会走系统默认的终止逻辑。把CatchOnce替换为Catch即可永久绑定SIGINT处理逻辑，多次触发只会往当前绑定的MVar写入值，不会终止程序。

仅依赖base和unix包，无需引入第三方库：

import Control.Concurrent (MVar, newEmptyMVar, tryTakeMVar, putMVar, threadDelay)
import System.Posix.Signals (installHandler, sigINT, Handler(..))

-- 可中断的延迟函数：最多等待delayUs微秒，提前收到MVar信号就返回True
interruptibleDelay :: MVar () -> Int -> IO Bool
interruptibleDelay v delayUs = go delayUs
  where
    -- 每次轮询间隔10毫秒，可根据需要调整响应灵敏度
    sliceUs = 10000
    go remaining = if remaining <= 0
      then return False
      else do
        threadDelay (min remaining sliceUs)
        tryTakeMVar v >>= \case
          Just _ -> return True
          Nothing -> go (remaining - sliceUs)

timer1 :: MVar () -> Int -> IO Int
timer1 v sec = do
  putStrLn (show sec)
  interrupted <- interruptibleDelay v 1000000
  if interrupted
    then return sec
    else if sec > 0 then timer1 v (sec - 1) else return 0

main :: IO ()
main = do
  -- 第一轮计时
  v1 <- newEmptyMVar
  installHandler sigINT (Catch $ putMVar v1 ()) Nothing
  res1 <- timer1 v1 5
  putStrLn $ "timer1: " ++ show res1

  -- 第二轮计时
  v2 <- newEmptyMVar
  -- 更新信号处理器绑定到新的MVar
  installHandler sigINT (Catch $ putMVar v2 ()) Nothing
  res2 <- timer1 v2 5
  putStrLn $ "timer1: " ++ show res2

如果允许引入async依赖，不需要手动实现轮询逻辑，代码更简洁：

import Control.Concurrent (MVar, newEmptyMVar, takeMVar, putMVar, threadDelay)
import Control.Concurrent.Async (race)
import System.Posix.Signals (installHandler, sigINT, Handler(..))

timer1 :: MVar () -> Int -> IO Int
timer1 v sec = do
  putStrLn (show sec)
  -- race会同时执行两个IO，任意一个完成就自动取消另一个
  race (threadDelay 1000000) (takeMVar v) >>= \case
    -- takeMVar先完成，说明触发了SIGINT
    Right _ -> return sec
    -- 延迟先完成，继续计时
    Left _ -> if sec > 0 then timer1 v (sec - 1) else return 0

main :: IO ()
main = do
  v1 <- newEmptyMVar
  installHandler sigINT (Catch $ putMVar v1 ()) Nothing
  res1 <- timer1 v1 5
  putStrLn $ "timer1: " ++ show res1

  v2 <- newEmptyMVar
  installHandler sigINT (Catch $ putMVar v2 ()) Nothing
  res2 <- timer1 v2 5
  putStrLn $ "timer1: " ++ show res2

内容的提问来源于stack exchange，提问作者Theerawat Kiatdarakun