Repository : ssh://darcs.haskell.org//srv/darcs/packages/haskeline On branch : master
http://hackage.haskell.org/trac/ghc/changeset/62fac92e4629982cc1dd8ee95d3915be5016e5b3 >--------------------------------------------------------------- commit 62fac92e4629982cc1dd8ee95d3915be5016e5b3 Author: Judah Jacobson <[email protected]> Date: Tue Jul 17 18:53:00 2012 +0000 Add back wrap/handleInterrupt. Although GHC provides similar functionality by default, it will terminate the program the second time that ctrl-c is pressed. In contrast, wrapInterrupt will throw an exception on every ctrl-c, which is better behavior for the types of programs that use haskeline. >--------------------------------------------------------------- System/Console/Haskeline.hs | 35 ++++++++++++++++++++++++++++ System/Console/Haskeline/Backend/Posix.hsc | 10 +++++++- System/Console/Haskeline/Backend/Win32.hsc | 26 ++++++++++++++++++++ System/Console/Haskeline/Term.hs | 9 +++++++ examples/Test.hs | 4 +- 5 files changed, 81 insertions(+), 3 deletions(-) diff --git a/System/Console/Haskeline.hs b/System/Console/Haskeline.hs index 8878ff4..91ca817 100644 --- a/System/Console/Haskeline.hs +++ b/System/Console/Haskeline.hs @@ -67,6 +67,10 @@ module System.Console.Haskeline( getHistory, putHistory, modifyHistory, + -- * Ctrl-C handling + withInterrupt, + Interrupt(..), + handleInterrupt, -- * Additional submodules module System.Console.Haskeline.Completion, module System.Console.Haskeline.MonadException) @@ -281,3 +285,34 @@ promptedInput doTerm doFile prompt = do let (lastLine,rest) = break (`elem` "\r\n") $ reverse prompt outputStr $ reverse rest doTerm tops $ reverse lastLine + +{- | If Ctrl-C is pressed during the given action, throw an exception +of type 'Interrupt'. For example: + +> tryAction :: InputT IO () +> tryAction = handle (\Interrupt -> outputStrLn "Cancelled.") +> $ wrapInterrupt $ someLongAction + +The action can handle the interrupt itself; a new 'Interrupt' exception will be thrown +every time Ctrl-C is pressed. + +> tryAction :: InputT IO () +> tryAction = wrapInterrupt loop +> where loop = handle (\Interrupt -> outputStrLn "Cancelled; try again." >> loop) +> someLongAction + +This behavior differs from GHC's built-in Ctrl-C handling, which +may immediately terminate the program after the second time that the user presses +Ctrl-C. + +-} +withInterrupt :: MonadException m => InputT m a -> InputT m a +withInterrupt act = do + rterm <- InputT ask + liftIOOp_ (wrapInterrupt rterm) act + +-- | Catch and handle an exception of type 'Interrupt'. +-- +-- > handleInterrupt f = handle $ \Interrupt -> f +handleInterrupt :: MonadException m => m a -> m a -> m a +handleInterrupt f = handle $ \Interrupt -> f diff --git a/System/Console/Haskeline/Backend/Posix.hsc b/System/Console/Haskeline/Backend/Posix.hsc index 1ea2897..4ffbf53 100644 --- a/System/Console/Haskeline/Backend/Posix.hsc +++ b/System/Console/Haskeline/Backend/Posix.hsc @@ -17,7 +17,7 @@ module System.Console.Haskeline.Backend.Posix ( import Foreign import Foreign.C.Types import qualified Data.Map as Map -import System.Posix.Terminal +import System.Posix.Terminal hiding (Interrupt) import Control.Monad import Control.Concurrent hiding (throwTo) import Data.Maybe (catMaybes) @@ -220,6 +220,13 @@ withWindowHandler :: MonadException m => Chan Event -> m a -> m a withWindowHandler eventChan = withHandler windowChange $ Catch $ writeChan eventChan WindowResize +withSigIntHandler :: MonadException m => m a -> m a +withSigIntHandler f = do + tid <- liftIO myThreadId + withHandler keyboardSignal + (Catch (throwTo tid Interrupt)) + f + withHandler :: MonadException m => Signal -> Handler -> m a -> m a withHandler signal handler f = do old_handler <- liftIO $ installHandler signal handler Nothing @@ -353,6 +360,7 @@ fileRunTerm h_in = do decoder' <- openPartialDecoder codeset return RunTerm {putStrOut = encoder >=> putTerm h_out, closeTerm = setLocale oldLocale >> return (), + wrapInterrupt = withSigIntHandler, termOps = Right FileOps { inputHandle = h_in, getLocaleChar = getMultiByteChar h_in decoder', diff --git a/System/Console/Haskeline/Backend/Win32.hsc b/System/Console/Haskeline/Backend/Win32.hsc index 97e5782..d6cb56e 100644 --- a/System/Console/Haskeline/Backend/Win32.hsc +++ b/System/Console/Haskeline/Backend/Win32.hsc @@ -391,6 +391,7 @@ fileRunTerm h_in = do return RunTerm { closeTerm = return (), putStrOut = putter, + wrapInterrupt = withCtrlCHandler, termOps = Right FileOps { inputHandle = h_in, getLocaleChar = getMultiByteChar cp h_in, @@ -415,6 +416,31 @@ putOut = do return $ \str -> unicodeToCodePage cp str >>= B.putStr >> hFlush stdout +type Handler = DWORD -> IO BOOL + +foreign import ccall "wrapper" wrapHandler :: Handler -> IO (FunPtr Handler) + +foreign import stdcall "windows.h SetConsoleCtrlHandler" c_SetConsoleCtrlHandler + :: FunPtr Handler -> BOOL -> IO BOOL + +-- sets the tv to True when ctrl-c is pressed. +withCtrlCHandler :: MonadException m => m a -> m a +withCtrlCHandler f = bracket (liftIO $ do + tid <- myThreadId + fp <- wrapHandler (handler tid) + -- don't fail if we can't set the ctrl-c handler + -- for example, we might not be attached to a console? + _ <- c_SetConsoleCtrlHandler fp True + return fp) + (\fp -> liftIO $ c_SetConsoleCtrlHandler fp False) + (const f) + where + handler tid (#const CTRL_C_EVENT) = do + throwTo tid Interrupt + return True + handler _ _ = return False + + ------------------------ -- Multi-byte conversion diff --git a/System/Console/Haskeline/Term.hs b/System/Console/Haskeline/Term.hs index e622199..a65204e 100644 --- a/System/Console/Haskeline/Term.hs +++ b/System/Console/Haskeline/Term.hs @@ -11,6 +11,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Word import Control.Exception (fromException, AsyncException(..),bracket_) +import Data.Typeable import System.IO import Control.Monad(liftM,when,guard) import System.IO.Error (isEOFError) @@ -32,6 +33,7 @@ data RunTerm = RunTerm { -- | Write unicode characters to stdout. putStrOut :: String -> IO (), termOps :: Either TermOps FileOps, + wrapInterrupt :: forall a . IO a -> IO a, closeTerm :: IO () } @@ -68,6 +70,13 @@ mapEvalTerm :: (forall a . n a -> m a) -> (forall a . m a -> n a) mapEvalTerm eval liftE (EvalTerm eval' liftE') = EvalTerm (eval . eval') (liftE' . liftE) +data Interrupt = Interrupt + deriving (Show,Typeable,Eq) + +instance Exception Interrupt where + + + class (MonadReader Prefs m , MonadReader Layout m, MonadException m) => CommandMonad m where runCompletion :: (String,String) -> m (String,[Completion]) diff --git a/examples/Test.hs b/examples/Test.hs index bbe1f02..7b25c7b 100644 --- a/examples/Test.hs +++ b/examples/Test.hs @@ -27,10 +27,10 @@ main = do ["password", [c]] -> getPassword (Just c) ["initial"] -> flip getInputLineWithInitial ("left ", "right") _ -> getInputLine - runInputT mySettings $ loop inputFunc 0 + runInputT mySettings $ withInterrupt $ loop inputFunc 0 where loop inputFunc n = do - minput <- handle (\UserInterrupt -> return (Just "Caught interrupted")) + minput <- handle (\Interrupt -> return (Just "Caught interrupted")) $ inputFunc (show n ++ ":") case minput of Nothing -> return () _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
