Captura de la excepción Control-C en GHC (Haskell)

Question

Creé un loop de lectura-evaluación-impresión realmente simple en Haskell que atrapa Control-C (UserInterrupt). Sin embargo, cada vez que compilo y ejecuto este programa, siempre atrapa el primer Control-C y siempre aborta en el segundo Control-C con el código de salida 130. No importa cuántas líneas de entrada le dé antes y entre los dos Control-C, siempre sucede de esta manera. Sé que debo estar perdiendo algo simple ... ¡por favor ayuda, gracias!

Nota: esto es con excepciones de base 4, por lo que Control.Exception y no Control.OldException.

import Control.Exception as E 
import System.IO 

main :: IO() 
main = do hSetBuffering stdout NoBuffering 
      hSetBuffering stdin NoBuffering 
      repLoop 

repLoop :: IO() 
repLoop 
    = do putStr "> " 
     line <- interruptible "<interrupted>" getLine 
     if line == "exit" 
      then putStrLn "goodbye" 
      else do putStrLn $ "input was: " ++ line 
        repLoop 

interruptible :: a -> IO a -> IO a 
interruptible a m 
    = E.handleJust f return m 
    where 
    f UserInterrupt 
     = Just a 
    f _ 
     = Nothing 

Answer 1

de responsabilidad: No estoy familiarizado con las partes internas de GHC y mi respuesta se basa en grepping el código fuente, la lectura de los comentarios, y haciendo conjeturas.

La función main se define de hecho es envuelto por runMainIO definido en GHC.TopHandler (esto se ve confirmado por mirar TcRnDriver.lhs):

-- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is 
-- called in the program). It catches otherwise uncaught exceptions, 
-- and also flushes stdout\/stderr before exiting. 
runMainIO :: IO a -> IO a 
runMainIO main = 
    do 
     main_thread_id <- myThreadId 
     weak_tid <- mkWeakThreadId main_thread_id 
     install_interrupt_handler $ do 
      m <- deRefWeak weak_tid 
      case m of 
       Nothing -> return() 
       Just tid -> throwTo tid (toException UserInterrupt) 
     a <- main 
     cleanUp 
     return a 
    `catch` 
     topHandler 

Y install_interrupt_handler se define como:

install_interrupt_handler :: IO() -> IO() 
#ifdef mingw32_HOST_OS 
install_interrupt_handler handler = do 
    _ <- GHC.ConsoleHandler.installHandler $ 
    Catch $ \event -> 
     case event of 
      ControlC -> handler 
      Break -> handler 
      Close -> handler 
      _ -> return() 
    return() 
#else 
#include "rts/Signals.h" 
-- specialised version of System.Posix.Signals.installHandler, which 
-- isn't available here. 
install_interrupt_handler handler = do 
    let sig = CONST_SIGINT :: CInt 
    _ <- setHandler sig (Just (const handler, toDyn handler)) 
    _ <- stg_sig_install sig STG_SIG_RST nullPtr 
    -- STG_SIG_RST: the second ^C kills us for real, just in case the 
    -- RTS or program is unresponsive. 
    return() 

En Linux, stg_sig_install es una función C que llama al sigaction. El parámetro STG_SIG_RST se traduce al SA_RESETHAND. En Windows, las cosas se hacen de forma diferente, lo que probablemente explica la observación de ja.

Answer 2

La solución más confiable para mí (al menos en Linux), ha sido instalar un manejador de señal usando System.Posix.Signals. Esperaba una solución que no lo requiriera, pero la verdadera razón por la que publiqué la pregunta fue porque quería saber por qué GHC se comportó de la manera en que lo hizo. Como se explica en #haskell, una explicación probable es que GHC se comporte de esta manera para que el usuario siempre pueda controlar una aplicación si se cuelga. Aún así, sería bueno si GHC proporcionara una forma de afectar este comportamiento sin el método de un nivel un poco más bajo al que recurrimos :).

Answer 3

Wei Hu es correcto; el sistema de tiempo de ejecución Haskell interrumpe deliberadamente el programa cuando se presiona un segundo control-C. Para obtener el comportamiento que cabría esperar:

import Control.Exception as E 
import Control.Concurrent 
import System.Posix.Signals 

main = do 
    tid <- myThreadId 
    installHandler keyboardSignal (Catch (throwTo tid UserInterrupt)) Nothing 
    ... -- rest of program