module SignalException ( withSignal ) where

import Control.Concurrent
import Control.Exception
import Data.FiniteMap
import System.Posix
import System.IO.Unsafe	( unsafePerformIO )
import Data.Dynamic
import System.IO

{-# NOINLINE sigmap #-}
sigmap :: MVar (FiniteMap Signal [ThreadId])
sigmap = unsafePerformIO $ newMVar emptyFM

registerSignal :: Signal -> ThreadId -> IO ()
registerSignal s t = do
  modifyMVar_ sigmap $ \fm -> 
	case lookupFM fm s of
		Nothing -> do 
		   putStr "hello1\n"; hFlush stdout; 
		   installHandler s (Catch (handleSignal s)) Nothing
		   return (addToFM fm s [t])
		Just ts ->
		   return (addToFM fm s (t:ts))

unregisterSignal :: Signal -> ThreadId -> IO ()
unregisterSignal s t = 
  modifyMVar_ sigmap $ \fm ->
	case lookupFM fm s of
		Nothing -> return fm
		Just ts -> return (addToFM fm s (filter (/= t) ts))

handleSignal :: Signal -> IO ()
handleSignal s = withMVar sigmap $ \fm ->
  case lookupFM fm s of
	Nothing -> return ()
	Just ts -> sequence_ [ throwDynTo t (SignalExcpetion s) | t <- ts ]

newtype SignalExcpetion = SignalExcpetion Signal deriving (Typeable)

withSignal :: Signal -> IO a -> IO a -> IO a
withSignal s handler job = do
  id <- myThreadId
  -- We can almost use bracket, but we want a specialised exception
  -- handler, so we have to inline bracket and modify it.
  block $ do
    registerSignal s id
    r <- Control.Exception.catch
	   (unblock job)
	   (\e -> do unregisterSignal s id
		     case e of
			DynException d
			    | Just (SignalExcpetion sig) <- fromDynamic d,
			      s == sig -> handler
			_other ->
				throw e
	  )
    unregisterSignal s id
    return r