forkIOInterruptible.hs

import            Data.IORef
import            System.Exit                           (exitSuccess, ExitCode(ExitSuccess))
import            Control.Concurrent
import            System.Posix.Signals                  -- (installHandler, Handler(Catch), sigINT, sigTERM)
import            Control.Concurrent.Lock               ( Lock )
import qualified  Control.Concurrent.Lock               as Lock

forkIOInterruptible io = do
  ctid <- forkIO io
  tid <- myThreadId
  oldHandlerRef <- newIORef Nothing
  let
    handler info = do
      f ctid
      readIORef oldHandlerRef >>= \x -> case x of
        Nothing                  -> noop
        Just Default             -> noop
        Just Ignore              -> noop
        Just (Catch io)          -> io
        Just (CatchInfo iof)     -> iof info
        Just (CatchInfoOnce iof) -> iof info

      f tid
  oldHandler <- installHandler sigINT (CatchInfoOnce $ handler) Nothing
  writeIORef oldHandlerRef (Just oldHandler)
  return ctid
  where
  -- f tid = throwTo tid ExitSuccess
  f = killThread
  noop = return ()