@@ -22,10 +22,6 @@
2222--
2323module Asyncly.AsyncT
2424 ( AsyncT (..)
25− -- , Step (..)
26− -- , stop
27− , waitA_
28− , eachA
2925-- , async
3026-- , makeAsync
3127
@@ -64,14 +60,14 @@ import Control.Monad.Trans.Recorder (MonadRecorder(..))
6460
6561import Asyncly.Threads (MonadAsync, Context)
6662
67−-- data Step a m = Stop | Yield a (AsyncT m a)
68−-- newtype AsyncT m a = AsyncT { runAsyncT :: m (Step a m) }
69−-- stop value is needed for Alternative instance
70−newtype AsyncT m a = AsyncT {
71− runAsyncT :: forall r.
72− m r
73− -> (a -> Maybe (AsyncT m a) -> m r)
74− -> m r
63+-- The 'Maybe' is redundant as we can use 'stop' value in place of Nothing,
64+-- but it makes the fold using '<|>' 25% faster.
65+newtype AsyncT m a =
66+ AsyncT {
67+ runAsyncT :: forall r.
68+ m r -- stop
69+ -> (a -> Maybe (AsyncT m a) -> m r) -- yield
70+ -> m r
7571 }
7672
7773------------------------------------------------------------------------------
@@ -88,32 +84,14 @@ dbg _ = return ()
8884-- Monad
8985------------------------------------------------------------------------------
9086
91−-- XXX need to wait for the async threads in case of a stop is returned due to
92−-- async thread spawning.
93−{-# SPECIALIZE parallel
94− :: AsyncT IO a
95− -> AsyncT IO a
96− -> AsyncT IO a #-}
97−{-# INLINE parallel #-}
98−parallel :: Monad m => AsyncT m a -> AsyncT m a -> AsyncT m a
99−parallel (AsyncT m1) m2 = AsyncT $ \stp yld ->
100− m1 ((runAsyncT m2) stp yld) (\a ax ->
101− case ax of
102− Just mx -> yld a (Just (parallel mx m2))
103− Nothing -> yld a (Just m2)
104− )
105−
10687instance MonadAsync m => Monad (AsyncT m) where
107− -- {-# SPECIALIZE instance Monad (AsyncT (StateT Context IO)) #-}
108− {-# SPECIALIZE instance Monad (AsyncT IO) #-}
10988 return a = AsyncT $ \_ yld -> yld a Nothing
11089
111− {-# INLINE (>>=) #-}
11290 AsyncT m >>= f = AsyncT $ \stp yld ->
113− m stp (\a ma ->
114− case ma of
115− Just mx -> (runAsyncT (parallel (f a) (mx >>= f))) stp yld
91+ m stp (\a r ->
92+ case r of
11693 Nothing -> (runAsyncT (f a)) stp yld
94+ Just rx -> (runAsyncT ((f a) <|> (rx >>= f))) stp yld
11795 )
11896
11997------------------------------------------------------------------------------
@@ -153,16 +131,21 @@ instance MonadAsync m => Applicative (AsyncT m) where
153131-- they can go away rather than waiting indefinitely.
154132
155133instance MonadAsync m => Alternative (AsyncT m) where
156− -- {-# SPECIALIZE instance Alternative (AsyncT (StateT Context IO)) #-}
157− {-# SPECIALIZE instance Alternative (AsyncT IO) #-}
158134 empty = AsyncT $ \stp _ -> stp
159− (<|>) m1 m2 = parallel m1 m2
135+
136+ -- XXX need to wait for the async threads in case of a stop is returned due
137+ -- to async thread spawning.
138+ AsyncT m1 <|> m2 = AsyncT $ \stp yld ->
139+ m1 ((runAsyncT m2) stp yld) (\a r ->
140+ case r of
141+ Nothing -> yld a (Just m2)
142+ Just rx -> yld a (Just (rx <|> m2))
143+ )
160144
161145instance MonadAsync m => MonadPlus (AsyncT m) where
162146 mzero = empty
163147 mplus = (<|>)
164148
165−{-
166149instance (Monoid a, MonadAsync m) => Monoid (AsyncT m a) where
167150 mappend x y = mappend <$> x <*> y
168151 mempty = return mempty
@@ -179,7 +162,6 @@ instance (Num a, Monad (AsyncT m)) => Num (AsyncT m a) where
179162 abs f = f >>= return . abs
180163 signum f = f >>= return . signum
181164
182−-}
183165-------------------------------------------------------------------------------
184166-- AsyncT transformer
185167-------------------------------------------------------------------------------
@@ -238,9 +220,8 @@ instance (MonadAsync m, MonadRecorder m) => MonadRecorder (AsyncT m) where
238220{-
239221-- | Run @m a@ before running @m b@. The result of @m a@ is discarded.
240222before :: MonadAsync m => AsyncT m a -> AsyncT m b -> AsyncT m b
241−before ma mb = AsyncT $ do
242− _ <- runAsyncT (ma >> mzero)
243− runAsyncT mb
223+before ma mb = AsyncT $ \stp yld ->
224+ (runAsyncT ma) ((runAsyncT mb) stp yld) yld
244225
245226infixr 1 *>>
246227-- | Same as 'before'.
@@ -305,28 +286,3 @@ async action = AsyncT $ runAsyncTask True (runAsyncT action)
305286makeAsync :: MonadAsync m => ((a -> m ()) -> m ()) -> AsyncT m a
306287makeAsync = AsyncT . makeCont
307288-}
308−
309−-- {-# SPECIALIZE waitA_ :: AsyncT IO a -> IO () #-}
310−waitA_ :: (MonadAsync m) => AsyncT m a -> m ()
311−waitA_ (AsyncT m) = m (return ()) (\_ r -> maybe (return ()) waitA_ r)
312−
313−{-
314−waitA :: forall m a. (MonadAsync m, MonadCatch m) => AsyncT m a -> m [a]
315−waitA (AsyncT m) = run m
316−
317− where
318−
319− run ma = do
320− ma >>= \a -> case a of
321− Yield x mb -> liftM (x :) (run mb ctx')
322− -- XXX pull from children here
323− Stop -> return []
324−-}
325−
326−-- scatter
327−-- XXX unthreaded case can be more efficient by yielding continuously rather
328−-- than folding a yield followed by Nothing in the parallel case.
329−{-# SPECIALIZE eachA :: [a] -> AsyncT IO a #-}
330−eachA :: (MonadIO m, MonadBaseControl IO m, MonadThrow m)
331− => [a] -> AsyncT m a
332−eachA xs = foldr (<|>) empty $ map return xs