[project @ 1996-01-08 20:28:12 by partain]

[ghc-hetmet.git] / ghc / misc / examples / posix / po004 / Main.hs

diff --git a/ghc/misc/examples/posix/po004/Main.hs b/ghc/misc/examples/posix/po004/Main.hs
new file mode 100644 (file)
index 0000000..1725dd4
--- /dev/null
+++ b/ghc/misc/examples/posix/po004/Main.hs
@@ -0,0 +1,58 @@
+import LibPosix
+import LibSystem(ExitCode(..), exitWith)
+
+main = 
+    forkProcess >>= \ maybe_pid ->
+    case maybe_pid of
+       Nothing -> raiseSignal floatingPointException
+       _ -> doParent
+
+doParent =
+    getAnyProcessStatus True False >>= \ (Just (pid, tc)) ->
+    case tc of
+       Terminated sig | sig == floatingPointException -> forkChild2
+       _ -> fail "unexpected termination cause"
+
+forkChild2 =
+    forkProcess >>= \ maybe_pid ->
+    case maybe_pid of
+       Nothing -> exitImmediately (ExitFailure 42)
+       _ -> doParent2
+    
+doParent2 =
+    getAnyProcessStatus True False >>= \ (Just (pid, tc)) ->
+    case tc of
+       Exited (ExitFailure 42) -> forkChild3
+       _ -> fail "unexpected termination cause (2)"
+           
+forkChild3 =
+    forkProcess >>= \ maybe_pid ->
+    case maybe_pid of
+       Nothing -> exitImmediately (ExitSuccess)
+       _ -> doParent3
+    
+doParent3 =
+    getAnyProcessStatus True False >>= \ (Just (pid, tc)) ->
+    case tc of
+       Exited ExitSuccess -> forkChild4
+       _ -> fail "unexpected termination cause (3)"
+           
+forkChild4 =
+    forkProcess >>= \ maybe_pid ->
+    case maybe_pid of
+       Nothing -> raiseSignal softwareStop
+       _ -> doParent4
+    
+doParent4 =
+    getAnyProcessStatus True True >>= \ (Just (pid, tc)) ->
+    case tc of
+       Stopped sig | sig == softwareStop -> enoughAlready pid
+       _ -> fail "unexpected termination cause (4)"
+           
+enoughAlready pid =
+    signalProcess killProcess pid >>
+    getAnyProcessStatus True True >>= \ (Just (pid, tc)) ->
+    case tc of
+       Terminated sig | sig == killProcess -> putStr "I'm happy.\n"
+       _ -> fail "unexpected termination cause (5)"
+