module Signal where

import Data.Maybe (fromMaybe)
import Control.Concurrent
import Control.Exception (Exception,catch,throw)
import Prelude hiding (catch)
import System.IO
import System.Posix.Signals

-- | Run an IO action, and allow it to be interrupted
--   by a SIGINT to the current process. Returns
--   an exception if the process did not complete 
--   normally.
--   NOTES: 
--   * This will replace any existing SIGINT
--     handler during the action. After the computation 
--     has completed the existing handler will be restored.
--   * If the IO action is lazy (e.g. using readFile,
--     unsafeInterleaveIO etc.) the lazy computation will
--     not be interruptible, as it will be performed
--     after the signal handler has been removed.
runInterruptibly :: IO a -> IO (Either Exception a)
runInterruptibly a = 
    do t <- myThreadId
       oldH <- installHandler sigINT (Catch (killThread t)) Nothing
       x <- p `catch` h
       installHandler sigINT oldH Nothing
       return x
  where p = a >>= \x -> return $! Right $! x
        h e = return $ Left e

-- | Like 'runInterruptibly', but always returns (), whether
--   the computation fails or not.
runInterruptibly_ :: IO () -> IO ()
runInterruptibly_ = fmap (either (const ()) id) . runInterruptibly


{-

-- needlessly complicated, is this ever better?

runInterruptibly :: IO a -> IO (Maybe a)
runInterruptibly f = do
                     c <- startComputation f
                     killComputationOnSignal c sigINT
                     x <- waitForComputation c
                     removeHandler sigINT
                     return x

type Computation a = (ThreadId,MVar (Maybe a))

startComputation :: IO a -> IO (Computation a)
startComputation f = do
                     v <- newEmptyMVar
                     t <- forkIO (a v)
                     return (t,v)
    where 
    -- the values is forced in the thread, to avoid lengthy 
    -- computations if the value is something slow and lazy.
    a v = (f >>= \x -> putMVar v $! Just $! x) `catch` h v
    -- the exception handler is run on exceptions, including
    -- when the thread is killed.
    h v e = do
            tryPutMVar v Nothing
            throw e

-- | Block until the computation finishes, either by returning
--   a result, or because it has been terminated or thrown
--   an exception.
waitForComputation :: Computation a -> IO (Maybe a)
waitForComputation (_,v) = takeMVar v

-- | Stop the computation. If the computation has not already
--   completed, this will cause 'waitForComputation' to return 'Nothing'
killComputation :: Computation a -> IO ()
killComputation (t,_) = killThread t

-- | Kill the given computation when the given signal is 
--   received. You nned to call 'removeHandler' after the 
--   computation completes to reset the signal handler,
--   and free the resources used by the computation.
killComputationOnSignal :: Computation a -> Signal -> IO ()
killComputationOnSignal c s = 
    installHandler s (Catch (killComputation c)) Nothing >> return ()

-- | Set the default handler for the given signal
removeHandler :: Signal -> IO ()
removeHandler s = installHandler s Default Nothing >> return ()

-}