{-# OPTIONS -cpp #-}
----------------------------------------------------------------------
-- |
-- Module      : GF.System.UseSignal
-- Maintainer  : Bjorn Bringert
-- Stability   : (stability)
-- Portability : (portability)
--
-- > CVS $Date: 2005/11/11 11:12:50 $ 
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.1 $
--
-- Allows SIGINT (Ctrl-C) to interrupt computations.
-----------------------------------------------------------------------------

module GF.System.UseSignal where

import Control.Concurrent (myThreadId, killThread)
import Control.Exception (SomeException,catch)
import Prelude hiding (catch)
--import System.IO

#ifdef mingw32_HOST_OS
import GHC.ConsoleHandler

myInstallHandler handler = installHandler handler
myCatch  = Catch . const
myIgnore = Ignore
#else
import System.Posix.Signals

myInstallHandler :: Handler -> IO Handler
myInstallHandler Handler
handler = Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigINT Handler
handler Maybe SignalSet
forall a. Maybe a
Nothing
myCatch :: IO () -> Handler
myCatch  = IO () -> Handler
Catch
myIgnore :: Handler
myIgnore = Handler
Ignore
#endif

{-# NOINLINE runInterruptibly #-}

-- | 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 SomeException a)
runInterruptibly :: IO a -> IO (Either SomeException a)
runInterruptibly IO a
a = 
    do ThreadId
t <- IO ThreadId
myThreadId
       Handler
oldH <- Handler -> IO Handler
myInstallHandler (IO () -> Handler
myCatch (ThreadId -> IO ()
killThread ThreadId
t))
       Either SomeException a
x <- IO (Either SomeException a)
forall a. IO (Either a a)
p IO (Either SomeException a)
-> (SomeException -> IO (Either SomeException a))
-> IO (Either SomeException a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO (Either SomeException a)
forall (m :: * -> *) a b. Monad m => a -> m (Either a b)
h
       Handler -> IO Handler
myInstallHandler Handler
oldH
       Either SomeException a -> IO (Either SomeException a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either SomeException a
x
  where p :: IO (Either a a)
p = IO a
a IO a -> (a -> IO (Either a a)) -> IO (Either a a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> Either a a -> IO (Either a a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a a -> IO (Either a a)) -> Either a a -> IO (Either a a)
forall a b. (a -> b) -> a -> b
$! a -> Either a a
forall a b. b -> Either a b
Right (a -> Either a a) -> a -> Either a a
forall a b. (a -> b) -> a -> b
$! a
x
        h :: a -> m (Either a b)
h a
e = Either a b -> m (Either a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a b -> m (Either a b)) -> Either a b -> m (Either a b)
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left a
e

-- | Like 'runInterruptibly', but always returns (), whether
--   the computation fails or not.
runInterruptibly_ :: IO () -> IO ()
runInterruptibly_ :: IO () -> IO ()
runInterruptibly_ = (Either SomeException () -> ())
-> IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SomeException -> ())
-> (() -> ()) -> Either SomeException () -> ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (() -> SomeException -> ()
forall a b. a -> b -> a
const ()) () -> ()
forall a. a -> a
id) (IO (Either SomeException ()) -> IO ())
-> (IO () -> IO (Either SomeException ())) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Either SomeException ())
forall a. IO a -> IO (Either SomeException a)
runInterruptibly

-- | Run an action with SIGINT blocked.
blockInterrupt :: IO a -> IO a
blockInterrupt :: IO a -> IO a
blockInterrupt IO a
a = 
    do Handler
oldH <- Handler -> IO Handler
myInstallHandler Handler
myIgnore
       a
x <- IO a
a
       Handler -> IO Handler
myInstallHandler Handler
oldH
       a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x