-- | This module allows you to receive POSIX signals as asynchronous
-- exceptions.  This is handy, as it allows you to respond to exceptions
-- using all the tools already available for dealing with asynchronous
-- exceptions.  One result of this is that the 'bracket' function can work
-- properly together with POSIX signals.  Another benefit is that it lets
-- you use 'block' and 'unblock' from "Control.Exeception" to avoid
-- receiveing exceptions at inconvenient times.

module SignalException ( withSignal, catchSignal ) where

import Control.Concurrent
import Control.Exception
import Data.FiniteMap
import System.Posix
import System.IO.Unsafe	( unsafePerformIO )
import Data.Dynamic
import System.IO
import Data.List ( nub, delete )

{-# 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 [t] -> do installHandler s Default Nothing
		               return (delFromFM fm s)
		Just ts -> return (addToFM fm s (delete 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 <- nub ts ]

newtype SignalExcpetion = SignalExcpetion Signal deriving (Typeable)

-- | withSignal runs a computation while responding to a given signal by
-- throwing an exception.  If the exception is not caught, it is responded
-- to by a default handler, given as the second argument to withSignal.

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

-- | 'catchSignal' allows you to catch a signal exception within a
-- withSignal call.

catchSignal :: IO a -> (Signal -> IO a) -> IO a
catchSignal job handler =
    job `Control.Exception.catchDyn` (\(SignalExcpetion sig) -> handler sig)