在Haskell中处理UserInterrupt异常

Question

I'm implementing a REPL for a Scheme interpreter in Haskell and I'd like to handle some async events like UserInterrupt, StackOverflow, HeapOverflow, etc... Basically, I'd like to stop the current computation when UserInterrupt occurs and print a suitable message when StackOverflow and HeapOverflow occur, etc. I implemented this as follows:

    repl evaluator = forever $ (do
        putStr ">>> " >> hFlush stdout
        out <- getLine >>= evaluator
        if null out
           then return ()
           else putStrLn out)
        `catch`
        onUserInterrupt

    onUserInterrupt UserInterrupt = putStrLn "\nUserInterruption"
    onUserInterrupt e = throw e

    main = do
        interpreter <- getMyLispInterpreter
        handle onAbort (repl $ interpreter "stdin")
        putStrLn "Exiting..."

    onAbort e = do
        let x = show (e :: SomeException)
        putStrLn $ "\nAborted: " ++ x

It works as expected with one exception. If I start the interpreter and press Ctrl-Z + Enter, I get:

    >>> ^Z

    Aborted: <stdin>: hGetLine: end of file
    Exiting...

That's correct. But if I start the interpreter and press Ctrl-C followed by Ctrl-Z + Enter I get:

    >>>
    UserInterruption
    >>> ^Z

And it hangs and I can't use the interpreter anymore. However, if I press Ctrl-C again, the REPL unblocks. I searched a lot and I can't figure out the reason of it. Can anyone explain me?

Many thanks!

Answer 1

Control-C handling does not work with catch : may be related to GHC #2301: Proper handling of SIGINT/SIGQUIT

Here is a working testcase, with the evaluator removed:

module Main where

import Prelude hiding (catch)

import Control.Exception ( SomeException(..),
                           AsyncException(..)
                         , catch, handle, throw)
import Control.Monad (forever)
import System.IO

repl :: IO ()
repl = forever $ (do
    putStr ">>> " >> hFlush stdout
    out <- getLine
    if null out
       then return ()
       else putStrLn out)
    `catch`
    onUserInterrupt

onUserInterrupt UserInterrupt = putStrLn "\nUserInterruption"
onUserInterrupt e = throw e

main = do
    handle onAbort repl
    putStrLn "Exiting..."

onAbort e = do
    let x = show (e :: SomeException)
    putStrLn $ "\nAborted: " ++ x

On Linux, Control-Z is not caught as Sjoerd mentioned. Perhaps you are on Windows, where Control-Z is used for EOF. We can signal EOF on Linux with Control-D, which replicates the behavior you saw:

>>> ^D
Aborted: <stdin>: hGetLine: end of file
Exiting...

EOF is handled by your handle/onAbort function, and Control-C is handled by catch/onUserInterrupt . The issue here is that your repl function will only catch the first Control-C -- the testcase can be simplified by removing the handle/onAbort function. As noted above, that Control-C handling does not work with catch may be related to GHC #2301: Proper handling of SIGINT/SIGQUIT .

The following version instead uses the Posix API to install a persistent signal handler for Control-C:

module Main where

import Prelude hiding (catch)

import Control.Exception ( SomeException(..),
                           AsyncException(..)
                         , catch, handle, throw)
import Control.Monad (forever)
import System.IO
import System.Posix.Signals

repl :: IO ()
repl = forever $ do
    putStr ">>> " >> hFlush stdout
    out <- getLine
    if null out
       then return ()
       else putStrLn out

reportSignal :: IO ()
reportSignal = putStrLn "\nkeyboardSignal"

main = do
    _ <- installHandler keyboardSignal (Catch reportSignal) Nothing
    handle onAbort repl
    putStrLn "Exiting..."

onAbort e = do
    let x = show (e :: SomeException)
    putStrLn $ "\nAborted: " ++ x

which can handle Control-Cs being pressed multiple times:

>>> ^C
keyboardSignal

>>> ^C
keyboardSignal

>>> ^C
keyboardSignal

If not using the Posix API, installing a persistent signal handler on Windows requires re-raising the exception each time it is caught, as described in http://suacommunity.com/dictionary/signals.php