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

4 files changed, 133 insertions, 1 deletions

diff --git a/src-3.0/GF/Command/Interpreter.hs b/src-3.0/GF/Command/Interpreter.hs
index 10730e7ef..24f16ea1d 100644
--- a/src-3.0/GF/Command/Interpreter.hs
+++ b/src-3.0/GF/Command/Interpreter.hs
@@ -10,6 +10,7 @@ import GF.Command.ParGFShell
 import GF.GFCC.API
 import GF.GFCC.Macros
 import GF.GFCC.DataGFCC
+import GF.System.Signal
 
 import GF.Data.ErrM ----
 
@@ -23,7 +24,10 @@ data CommandEnv = CommandEnv {
 interpretCommandLine :: CommandEnv -> String -> IO ()
 interpretCommandLine env line = case (pCommandLine (myLexer line)) of
   Ok CEmpty -> return ()
-  Ok (CLine pipes) -> mapM_ interPipe pipes
+  Ok (CLine pipes) -> do res <- runInterruptibly (mapM_ interPipe pipes)
+                         case res of
+                           Left ex -> print ex
+                           Right x -> return x
   _ -> putStrLn "command not parsed"
  where
    interPipe (PComm cs) = do
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