From abf9823601eac8beb9281ef5cd48e088793442b2 Mon Sep 17 00:00:00 2001
From: bringert <unknown>
Date: Mon, 7 Nov 2005 19:15:05 +0000
Subject: [PATCH] Allow interrupting commands with Ctrl-C. Catch exceptions
 throw by commands.

---
 src/GF/Shell.hs         | 23 ++++++++++++++++----
 src/GF/System/Signal.hs | 47 +++++++++++++++++++++++++++++++++++++++++
 2 files changed, 66 insertions(+), 4 deletions(-)
 create mode 100644 src/GF/System/Signal.hs

diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs
index 488504c65..cdacb7989 100644
--- a/src/GF/Shell.hs
+++ b/src/GF/Shell.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/31 19:02:35 $ 
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.49 $
+-- > CVS $Date: 2005/11/07 20:15:05 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.50 $
 --
 -- GF shell command interpreter.
 -----------------------------------------------------------------------------
@@ -52,6 +52,7 @@ import GF.Grammar.PrGrammar
 
 import Control.Monad (foldM,liftM)
 import System (system)
+import System.IO (hPutStrLn, stderr)
 import System.Random (newStdGen) ----
 import Data.List (nub,isPrefixOf)
 import GF.Data.Zipper ----
@@ -60,6 +61,9 @@ import GF.Data.Operations
 import GF.Infra.UseIO
 import GF.Text.UTF8 (encodeUTF8)
 import Data.Char (isDigit)
+import Data.Maybe (fromMaybe)
+
+import GF.System.Signal (runInterruptibly)
 
 ---- import qualified GrammarToGramlet as Gr
 ---- import qualified GrammarToCanonXML2 as Canon
@@ -135,10 +139,21 @@ earlierCommandH (_,(h,_,_,_)) = ((h ++ repeat "") !!)
 
 execLinesH :: String -> [CommandLine] -> HState -> IO HState
 execLinesH s cs hst@(st, (h,_,_,_)) = do
-  (_,st') <- execLines True cs hst
+  (_,st') <- execLinesI True cs hst
   cpu     <- prOptCPU (optsHState st') (cpuHState hst)
   return $ putHStateCPU cpu $ updateHistory s st'
 
+-- | Like 'execLines', but can be interrupted by SIGINT.
+execLinesI :: Bool -> [CommandLine] -> HState -> IO ([String],HState)
+execLinesI put cs st = 
+    do
+    x <- runInterruptibly (execLines put cs st)
+    case x of
+           Left ex -> do hPutStrLn stderr ""
+                         hPutStrLn stderr $ show ex
+                         return ([],st)
+           Right y -> return y
+
 ifImpure :: [CommandLine] -> Maybe (ImpureCommand,Options)
 ifImpure cls = foldr (const . Just) Nothing [(c,os) | ((CImpure c,os),_,_) <- cls]
 
diff --git a/src/GF/System/Signal.hs b/src/GF/System/Signal.hs
new file mode 100644
index 000000000..7c39a53ca
--- /dev/null
+++ b/src/GF/System/Signal.hs
@@ -0,0 +1,47 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.System.Signal
+-- Maintainer  : Bjorn Bringert
+-- Stability   : (stability)
+-- Portability : (portability)
+--
+-- > CVS $Date: 2005/11/07 20:15:05 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.1 $
+--
+-- Allows SIGINT (Ctrl-C) to interrupt computations.
+-----------------------------------------------------------------------------
+
+module GF.System.Signal where
+
+import Control.Concurrent (myThreadId, killThread)
+import Control.Exception (Exception,catch)
+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
+--     handlers, and after the computation has completed
+--     the default handler will be installed for SIGINT.
+--   * 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
+                        installHandler sigINT (Catch (killThread t)) Nothing
+                        x <- p `catch` h
+                        installHandler sigINT Default 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