no silent drop of actor exceptions

copton · Aug 30, 2012 · 0f3240c · 0f3240c
1 parent 77691ca
commit 0f3240c
Show file tree

Hide file tree

Showing 4 changed files with 16 additions and 9 deletions.
diff --git a/ruab/src/Ruab/Actor.hs b/ruab/src/Ruab/Actor.hs
@@ -2,12 +2,13 @@ module Ruab.Actor
 -- exports {{{1
 (
     Actor, Quit, Update
-  , new_actor
+  , new_actor, monitor, monitor_async
   , update
  , quit, wait, kill
 ) where
 
 -- imports {{{1
+import Control.Exception.Base (throwIO)
 import Control.Concurrent.STM (atomically, TChan, newTChanIO, writeTChan, readTChan)
 import Control.Concurrent (forkIO, killThread, ThreadId, MVar, newEmptyMVar, takeMVar, putMVar)
 import Control.Exception.Base (SomeException, catch)
@@ -31,6 +32,12 @@ new_actor s0 = do
   thread <- forkIO $ actor quitFlag inbox s0
   return $ Actor thread inbox quitFlag
 
+monitor :: Actor a -> IO () -- {{{1
+monitor a = wait a >>= either throwIO (return . const ())
+
+monitor_async :: Actor a -> IO () -- {{{1
+monitor_async a = forkIO (monitor a) >> return ()
+
 update :: Actor a -> Update a -> IO () -- {{{1
 update a u = send a (Right u)
 

diff --git a/ruab/src/Ruab/Core.hs b/ruab/src/Ruab/Core.hs
@@ -26,7 +26,7 @@ import Data.Digest.OpenSSL.MD5 (md5sum)
 import Data.List (intercalate, find, nub)
 import Data.Maybe (catMaybes, fromJust, isJust)
 import Prelude hiding (catch)
-import Ruab.Actor (new_actor, update)
+import Ruab.Actor (new_actor, update, monitor_async)
 import Ruab.Core.Internal
 import Ruab.Options (Options(optDebugFile))
 import Ruab.Util (fromJust_s, abort, head_s)
@@ -142,6 +142,7 @@ create_network :: Context -> Options -> Fire Response -> Fire Status -> IO (Fire
 create_network ctx opt fResponse fStatus = do
   let s0 = initialState ctx
   aCore <- new_actor s0
+  monitor_async aCore
   let
     fCore f = update aCore $ \state -> do
       state' <- f state

diff --git a/ruab/src/Ruab/Core/Test.hs b/ruab/src/Ruab/Core/Test.hs
@@ -3,12 +3,12 @@
 module Ruab.Core.Test (tests) where
 
 -- imports {{{1
-import Control.Exception.Base (throwIO, try, SomeException)
+import Control.Exception.Base (try, SomeException)
 import Control.Monad.Fix (mfix)
 import Control.Monad (forM_, when)
 import Data.List (intercalate, find)
 import Data.Maybe (fromJust, isJust)
-import Ruab.Actor (new_actor, update, wait, quit)
+import Ruab.Actor (new_actor, update, quit, monitor)
 import Ruab.Core.Internal (t2p_row', p2t_row')
 import Ruab.Core
 import Ruab.Options (Options(..))
@@ -234,10 +234,7 @@ test_integration = enumTestGroup "integration" $ map runTest [
             (fire actor fCommand' InputStatus)
         )
       fCommand command
-      result <- wait actor
-      case result of
-        Left e -> throwIO e
-        Right _ -> return ()
+      monitor actor
 
     runTest _ = assertFailure "illegal script. Expect scripts must start with ExpectStart"
 

diff --git a/ruab/src/Ruab/Frontend.hs b/ruab/src/Ruab/Frontend.hs
@@ -14,7 +14,7 @@ import Graphics.UI.Gtk.Glade (xmlNew, xmlGetWidget)
 import Graphics.UI.Gtk.Gdk.Events (Event(Key))
 import Paths_Ruab (getDataFileName)
 import Prelude hiding (log, lines)
-import Ruab.Actor (new_actor, update)
+import Ruab.Actor (new_actor, monitor_async, update)
 import Ruab.Frontend.Infos (setHighlight, InfoInstance, render_info, setBreakpoint, infoIsHighlight, setThread, Row(getRow))
 import Ruab.Options (Options)
 import Ruab.Util (fromJust_s)
@@ -229,6 +229,7 @@ createNetwork :: Context -> Options -> IO () -- {{{2
 createNetwork ctx@(Context gui core) opt = do
   let infos = foldr (flip setBreakpoint 0) [] $ C.possible_breakpoints core
   aInfo <- new_actor infos
+  monitor_async aInfo
   let
     fInfo u = update aInfo (\s -> do
         let s' = u s
@@ -243,6 +244,7 @@ createNetwork ctx@(Context gui core) opt = do
   let fCommand  = handleCommand core fInfo fLog fCore
 
   aInput <- new_actor (InputState [] [])
+  monitor_async aInput
   let fInput = update aInput . handleInput (guiInput gui) fLog fCommand
 
   _ <- onDestroy (guiWin gui) (fCommand CmdQuit)