@@ -68,10 +68,10 @@ import Control.Monad.Trans.Recorder (MonadRecorder(..))
6868-- Parent child thread communication types
6969------------------------------------------------------------------------------
7070
71−-- XXX for threads that yield a single value we can pack yield and done in
72−-- ChildDone (Either exception value) so that we do not use two messages over
73−-- the channel where we can use just one.
74−data ChildEvent a = ChildYield a | ChildDone ThreadId (Maybe SomeException)
71+data ChildEvent a =
72+ ChildYield a
73+ | ChildDone ThreadId a
74+ | ChildStop ThreadId (Maybe SomeException)
7575
7676------------------------------------------------------------------------------
7777-- State threaded around the monad for thread management
@@ -170,17 +170,20 @@ push context action = run (Just context) action
170170
171171 where
172172
173− run ctx m = (runAsyncT m) ctx channelDone yield
173+ run ctx m = (runAsyncT m) ctx channelStop yield
174174
175175 -- XXX make this a bounded channel so that we block if the previous value
176176 -- is not consumed yet.
177177 chan = childChannel context
178178 channelYield a = liftIO $ atomically $ writeTChan chan (ChildYield a)
179− channelDone = do
179+ channelDone a = do
180180 tid <- liftIO myThreadId
181− liftIO $ atomically $ writeTChan chan (ChildDone tid Nothing)
181+ liftIO $ atomically $ writeTChan chan (ChildDone tid a)
182+ channelStop = do
183+ tid <- liftIO myThreadId
184+ liftIO $ atomically $ writeTChan chan (ChildStop tid Nothing)
182185
183− done a = channelYield a >> channelDone
186+ done a = channelDone a
184187 continue a ctx m = channelYield a >> run ctx m
185188 yield a ctx r = maybe (done a) (\rx -> continue a ctx rx) r
186189
@@ -191,7 +194,7 @@ push context action = run (Just context) action
191194handlePushException :: TChan (ChildEvent a) -> SomeException -> IO ()
192195handlePushException pchan e = do
193196 tid <- myThreadId
194− atomically $ writeTChan pchan (ChildDone tid (Just e))
197+ atomically $ writeTChan pchan (ChildStop tid (Just e))
195198
196199-- | run m1 in a new thread, pushing its results to a pull channel and then run
197200-- m2 in the parent thread. Any exceptions are also pushed to the channel.
@@ -219,7 +222,8 @@ pull ctx = AsyncT $ \_ stp yld -> do
219222 Right ev ->
220223 case ev of
221224 ChildYield a -> yld a Nothing (Just (pull ctx))
222− ChildDone _ e -> do
225+ ChildDone _ a -> yld a Nothing (Just (pull ctx))
226+ ChildStop _ e -> do
223227 let continue = (runAsyncT (pull ctx)) (Just ctx) stp yld
224228 maybe continue throwM e
225229