From 53bfa43a5820e0ac6cceb01b57776ae01b3b92f1 Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Fri, 23 May 2008 15:16:28 +0000 Subject: [PATCH] allow Ctrl+Break in the shell. Works on Windows too. --- GF.cabal | 9 ++++ src-3.0/GF/Command/Interpreter.hs | 6 ++- src-3.0/GF/System/NoSignal.hs | 29 +++++++++++++ src-3.0/GF/System/Signal.hs | 27 ++++++++++++ src-3.0/GF/System/UseSignal.hs | 72 +++++++++++++++++++++++++++++++ 5 files changed, 142 insertions(+), 1 deletion(-) create mode 100644 src-3.0/GF/System/NoSignal.hs create mode 100644 src-3.0/GF/System/Signal.hs create mode 100644 src-3.0/GF/System/UseSignal.hs diff --git a/GF.cabal b/GF.cabal index e94646b08..99b331748 100644 --- a/GF.cabal +++ b/GF.cabal @@ -11,6 +11,9 @@ flag readline Description: Enable Readline in the shell Default: True +flag interrupt + Description: Enable Ctrl+Break in the shell + Default: True library build-depends: base, @@ -174,3 +177,9 @@ executable gf3 other-modules: GF.System.UseReadline else other-modules: GF.System.NoReadline + + if flag(interrupt) + ghc-options: -DUSE_INTERRUPT + other-modules: GF.System.UseSignal + else + other-modules: GF.System.NoSignal 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