@@ -18,6 +18,7 @@
18module Asyncly.AsyncT
18module Asyncly.AsyncT
19 ( AsyncT (..)
19 ( AsyncT (..)
20 , MonadAsync
20 , MonadAsync
22-- , makeAsync
23-- , makeAsync
@@ -107,8 +108,8 @@ instance Monad m => Monoid (AsyncT m a) where
107 mempty = AsyncT $ \_ stp _ -> stp
108 mempty = AsyncT $ \_ stp _ -> stp
108 mappend (AsyncT m1) m2 = AsyncT $ \ctx stp yld ->
109 mappend (AsyncT m1) m2 = AsyncT $ \ctx stp yld ->
109 m1 ctx ((runAsyncT m2) ctx stp yld) $ \a _ r ->
110 m1 ctx ((runAsyncT m2) ctx stp yld) $ \a _ r ->
110− let yield x = yld a ctx (Just x)
111+ let yielder x = yld a ctx (Just x)
111− in maybe (yield m2) (\rx -> yield $ mappend rx m2) r
112+ in maybe (yielder m2) (\rx -> yielder $ mappend rx m2) r
113-- We do not use bind for parallelism. That is, we do not start each iteration
114-- We do not use bind for parallelism. That is, we do not start each iteration
114-- of the list in parallel. That will introduce too much uncontrolled
115-- of the list in parallel. That will introduce too much uncontrolled
@@ -133,6 +134,9 @@ instance Monad m => Monad (AsyncT m) where
133 next = f a
134 next = f a
134 in maybe (run next) (\rx -> run $ next <> (rx >>= f)) r
135 in maybe (run next) (\rx -> run $ next <> (rx >>= f)) r
137+yield :: a -> AsyncT m a -> AsyncT m a
138+yield a m = AsyncT $ \ctx _ yld -> yld a ctx (Just m)
136------------------------------------------------------------------------------
140------------------------------------------------------------------------------
137-- Functor
141-- Functor
138------------------------------------------------------------------------------
142------------------------------------------------------------------------------
@@ -171,7 +175,7 @@ push context action = run (Just context) action
174− run ctx m = (runAsyncT m) ctx channelStop yield
178+ run ctx m = (runAsyncT m) ctx channelStop yielder
176 -- XXX make this a bounded channel so that we block if the previous value
180 -- XXX make this a bounded channel so that we block if the previous value
177 -- is not consumed yet.
181 -- is not consumed yet.
@@ -186,7 +190,7 @@ push context action = run (Just context) action
187 done a = channelDone a
191 done a = channelDone a
188 continue a ctx m = channelYield a >> run ctx m
192 continue a ctx m = channelYield a >> run ctx m
189− yield a ctx r = maybe (done a) (\rx -> continue a ctx rx) r
193+ yielder a ctx r = maybe (done a) (\rx -> continue a ctx rx) r
191-- If an exception occurs we push it to the channel so that it can handled by
195-- If an exception occurs we push it to the channel so that it can handled by
192-- the parent. 'Paused' exceptions are to be collected at the top level.
196-- the parent. 'Paused' exceptions are to be collected at the top level.
@@ -220,10 +224,10 @@ pull ctx = AsyncT $ \_ stp yld -> do
220 Just BlockedIndefinitelyOnSTM -> stp
224 Just BlockedIndefinitelyOnSTM -> stp
221 Nothing -> throwM e
225 Nothing -> throwM e
222 Right ev ->
226 Right ev ->
223− let yield a = yld a Nothing (Just (pull ctx))
227+ let yielder a = yld a Nothing (Just (pull ctx))
224 in case ev of
228 in case ev of
225− ChildYield a -> yield a
229+ ChildYield a -> yielder a
226− ChildDone _ a -> yield a
230+ ChildDone _ a -> yielder a
227 ChildStop _ e -> do
231 ChildStop _ e -> do
228 let continue = (runAsyncT (pull ctx)) (Just ctx) stp yld
232 let continue = (runAsyncT (pull ctx)) (Just ctx) stp yld
229 in maybe continue throwM e
233 in maybe continue throwM e