Script that demonstrates the synchrony of 'throwTo'

async-exception-synchrony.hs

#!/usr/bin/env stack
{- stack
     --resolver lts-17.10
     --install-ghc
     script
       --optimize
-}

-- This script demonstrates the synchrony of "Control.Exception.throwTo", in
-- that calling the function is only synchronous until the asynchronous
-- exception has been raised in the target thread. If the calling thread needs
-- to wait on the target thread's exception handlers to complete, then
-- explicit synchronization is required.

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}

import Control.Concurrent.STM (TVar)
import Prelude
import qualified Control.Concurrent as Concurrent
import qualified Control.Concurrent.STM as STM
import qualified Control.Exception as Exception
import qualified System.Environment as Environment

main :: IO ()
main = do
  Environment.getArgs >>= \case
    -- Should in general print out the following:
    --   main is spawning a thread
    --   main is waiting a couple seconds
    --   main is killing the thread
    --   ThreadId 2: starting cleanup
    --   main is again waiting a couple seconds
    --   main is done
    ["--without-synchronized-cleanup"] -> do
      putStrLn "main is spawning a thread"
      threadId <- Concurrent.forkIO do
        Exception.onException (Concurrent.threadDelay 10000000) do
          threadId <- Concurrent.myThreadId
          let prefix = show threadId <> ": "
          putStrLn $ prefix <> "starting cleanup"
          Concurrent.threadDelay 10000000
          putStrLn $ prefix <> "cleanup finished"

      putStrLn "main is waiting a couple seconds"
      Concurrent.threadDelay 2000000

      putStrLn "main is killing the thread"
      Concurrent.killThread threadId

      putStrLn "main is again waiting a couple seconds"
      Concurrent.threadDelay 2000000

      putStrLn "main is done"

    -- Should in general print out the following:
    --  main is spawning a thread
    --  main is waiting a couple seconds
    --  main is killing the thread
    --  ThreadId 2: starting cleanup
    --  ThreadId 2: cleanup finished
    --  main is done
    ["--with-synchronized-cleanup"] -> do
      putStrLn "main is spawning a thread"
      cleanupDoneRef <- STM.newTVarIO False
      threadId <- Concurrent.forkIO do
        Exception.onException (Concurrent.threadDelay 10000000) do
          threadId <- Concurrent.myThreadId
          let prefix = show threadId <> ": "
          putStrLn $ prefix <> "starting cleanup"
          Concurrent.threadDelay 10000000
          putStrLn $ prefix <> "cleanup finished"
          STM.atomically $ STM.writeTVar cleanupDoneRef True

      putStrLn "main is waiting a couple seconds"
      Concurrent.threadDelay 2000000

      putStrLn "main is killing the thread"
      Concurrent.killThread threadId

      STM.atomically $ STM.check =<< STM.readTVar cleanupDoneRef
      putStrLn "main is done"

    invalidArgs -> do
      putStrLn $ "Missing flag:"
      putStrLn $ "  Must specify one of [--without-synchronized-cleanup, --with-synchronized-cleanup]"