allow Ctrl+Break in the shell. Works on Windows too.

3 files changed, 128 insertions, 0 deletions

diff --git a/src-3.0/GF/System/NoSignal.hs b/src-3.0/GF/System/NoSignal.hs
new file mode 100644
index 000000000..5d82a431e
--- /dev/null
+++ b/src-3.0/GF/System/NoSignal.hs
@@ -0,0 +1,29 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.System.NoSignal
+-- Maintainer  : Bjorn Bringert
+-- Stability   : (stability)
+-- Portability : (portability)
+--
+-- > CVS $Date: 2005/11/11 11:12:50 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.1 $
+--
+-- Dummy implementation of signal handling.
+-----------------------------------------------------------------------------
+
+module GF.System.NoSignal where
+
+import Control.Exception (Exception,catch)
+import Prelude hiding (catch)
+
+{-# NOINLINE runInterruptibly #-}
+runInterruptibly :: IO a -> IO (Either Exception a)
+--runInterruptibly = fmap Right
+runInterruptibly a = 
+    p `catch` h
+  where p = a >>= \x -> return $! Right $! x
+        h e = return $ Left e
+
+blockInterrupt :: IO a -> IO a
+blockInterrupt = id
diff --git a/src-3.0/GF/System/Signal.hs b/src-3.0/GF/System/Signal.hs
new file mode 100644
index 000000000..fe8a12483
--- /dev/null
+++ b/src-3.0/GF/System/Signal.hs
@@ -0,0 +1,27 @@
+{-# OPTIONS -cpp #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.System.Signal
+-- Maintainer  : Bjorn Bringert
+-- Stability   : (stability)
+-- Portability : (portability)
+--
+-- > CVS $Date: 2005/11/11 11:12:50 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.3 $
+--
+-- Import the right singal handling module.
+-----------------------------------------------------------------------------
+
+module GF.System.Signal (runInterruptibly,blockInterrupt) where
+
+#ifdef USE_INTERRUPT
+
+import GF.System.UseSignal (runInterruptibly,blockInterrupt)
+
+#else
+
+import GF.System.NoSignal (runInterruptibly,blockInterrupt)
+
+#endif
diff --git a/src-3.0/GF/System/UseSignal.hs b/src-3.0/GF/System/UseSignal.hs
new file mode 100644
index 000000000..628f5888d
--- /dev/null
+++ b/src-3.0/GF/System/UseSignal.hs
@@ -0,0 +1,72 @@
+{-# 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 (Exception,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 = installHandler sigINT handler Nothing
+myCatch  = Catch
+myIgnore = 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 Exception a)
+runInterruptibly a = 
+    do t <- myThreadId
+       oldH <- myInstallHandler (myCatch (print "Seek and Destroy" >> killThread t))
+       x <- p `catch` h
+       myInstallHandler oldH
+       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
+
+-- | Run an action with SIGINT blocked.
+blockInterrupt :: IO a -> IO a
+blockInterrupt a = 
+    do oldH <- myInstallHandler Ignore
+       x <- a
+       myInstallHandler oldH
+       return x