[commit: packages/base] master: Add tests for the top level exception handler (dd00004)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/base

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/dd0000410efef9fe92375475f93e43d2ad3e4492/base

>---------------------------------------------------------------

commit dd0000410efef9fe92375475f93e43d2ad3e4492
Author: Duncan Coutts <duncan at well-typed.com>
Date:   Thu Nov 14 15:16:30 2013 +0000

    Add tests for the top level exception handler
    
    The top level exception handler is wrapped around main, and FFI exports.
    It handles exceptions that are not otherwise caught in user code. For
    most exception is just prints them, but handles a few specially,
    including ExitCode and UserInterrupt.
    
    On Unix it installs a signal handler for SIGINT to translate it into a
    UserInterrupt async exception.
    
    So we test that:
    
    1. receiving SIGINT does trigger a UserInterrupt async exception
    2. an unhandled UserInterrupt makes us kill ourselves with SIGINT
    3. an unhandled ExitFailure (-sig) makes us kill ourselves with sig


>---------------------------------------------------------------

dd0000410efef9fe92375475f93e43d2ad3e4492
 tests/all.T               |    5 +++++
 tests/topHandler01.hs     |   16 ++++++++++++++++
 tests/topHandler01.stdout |    1 +
 tests/topHandler02.hs     |    7 +++++++
 tests/topHandler03.hs     |    8 ++++++++
 5 files changed, 37 insertions(+)

diff --git a/tests/all.T b/tests/all.T
index 55b9e9d..efc5ca9 100644
--- a/tests/all.T
+++ b/tests/all.T
@@ -134,3 +134,8 @@ test('CatEntail', normal, compile, [''])
 
 test('T7653', normal, compile_and_run, [''])
 test('T7787', normal, compile_and_run, [''])
+
+test('topHandler01', when(opsys('mingw32'), skip), compile_and_run, [''])
+test('topHandler02', [ when(opsys('mingw32'), skip), exit_code(130), omit_ways(['ghci']) ], compile_and_run, [''])
+test('topHandler03', [ when(opsys('mingw32'), skip), exit_code(143) ], compile_and_run, [''])
+
diff --git a/tests/topHandler01.hs b/tests/topHandler01.hs
new file mode 100644
index 0000000..0ee4bcb
--- /dev/null
+++ b/tests/topHandler01.hs
@@ -0,0 +1,16 @@
+import System.Posix.Process
+import System.Posix.Signals
+import Control.Exception
+import Control.Concurrent
+
+-- Test that a simulated ^C sends an async UserInterrupt
+-- exception to the main thread.
+
+main = handle userInterrupt $ do
+  us <- getProcessID
+  signalProcess sigINT us
+  threadDelay 1000000
+  putStrLn "Fail: never received  exception"
+
+userInterrupt UserInterrupt = putStrLn "Success: caught UserInterrupt"
+userInterrupt e             = putStrLn "Fail: caught unexpected exception"
diff --git a/tests/topHandler01.stdout b/tests/topHandler01.stdout
new file mode 100644
index 0000000..1679411
--- /dev/null
+++ b/tests/topHandler01.stdout
@@ -0,0 +1 @@
+Success: caught UserInterrupt
diff --git a/tests/topHandler02.hs b/tests/topHandler02.hs
new file mode 100644
index 0000000..270239c
--- /dev/null
+++ b/tests/topHandler02.hs
@@ -0,0 +1,7 @@
+import Control.Exception
+import Control.Concurrent
+
+-- Test that a UserInterrupt exception that propagates to the top level
+-- causes the process to terminate by killing itself with SIGINT
+
+main = throwIO UserInterrupt
diff --git a/tests/topHandler03.hs b/tests/topHandler03.hs
new file mode 100644
index 0000000..01f69af
--- /dev/null
+++ b/tests/topHandler03.hs
@@ -0,0 +1,8 @@
+import System.Posix.Signals
+import System.Exit
+import Data.Bits
+
+-- Test that a ExitFailure representing SIGTERM causes
+-- the process to terminate by killing itself with SIGTERM
+
+main = exitWith (ExitFailure (fromIntegral (-sigTERM)))