Exceptions that should be caught... aren't

t.hs

{-# LANGUAGE DeriveDataTypeable #-}

import Prelude hiding (catch)
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.Typeable



data PingPong = Ping ThreadId | Pong ThreadId deriving (Show, Typeable)
instance Exception PingPong

throwBack :: PingPong -> IO ()
throwBack (Ping tid) = myThreadId >>= throwTo tid . Pong
throwBack (Pong tid) = myThreadId >>= throwTo tid . Ping



sleeper :: IO ThreadId
sleeper =
  mask_ $
  forkIOWithUnmask $ \restore ->
    forever $
      restore sleep `catch` throwBack

sleep :: IO ()
sleep = threadDelay (10^(6::Int))



breaker :: ThreadId -> IO ThreadId
breaker tid = forkIO $ throwBack (Pong tid)


main :: IO ()
main = do
  tid <- sleeper
  replicateM_ 100 (breaker tid)
  sleep