git.iko.soy/streamly
on master help sign in
Some cleanup
a20c180Harendra Kumar
src/Asyncly.hs−2
compare with master
unifiedsplit
@@ -128,8 +128,6 @@ module Asyncly
128 , wait
128 , wait
129 , wait_
129 , wait_
130-- , threads
130-- , threads
131− , waitA_
132− , eachA
133 , each
131 , each
134
132
135{-
133{-
src/Asyncly/AsyncT.hs+22−66
@@ -22,10 +22,6 @@
22--
22--
23module Asyncly.AsyncT
23module Asyncly.AsyncT
24 ( AsyncT (..)
24 ( AsyncT (..)
25− -- , Step (..)
26− -- , stop
27− , waitA_
28− , eachA
29-- , async
25-- , async
30-- , makeAsync
26-- , makeAsync
31
27
@@ -64,14 +60,14 @@ import Control.Monad.Trans.Recorder (MonadRecorder(..))
64
60
65import Asyncly.Threads (MonadAsync, Context)
61import Asyncly.Threads (MonadAsync, Context)
66
62
67−-- data Step a m = Stop | Yield a (AsyncT m a)
63+-- The 'Maybe' is redundant as we can use 'stop' value in place of Nothing,
68−-- newtype AsyncT m a = AsyncT { runAsyncT :: m (Step a m) }
64+-- but it makes the fold using '<|>' 25% faster.
69−-- stop value is needed for Alternative instance
70−newtype AsyncT m a = AsyncT {
65+newtype AsyncT m a =
66+ AsyncT {
71− runAsyncT :: forall r.
67+ runAsyncT :: forall r.
72− m r
68+ m r -- stop
73− -> (a -> Maybe (AsyncT m a) -> m r)
69+ -> (a -> Maybe (AsyncT m a) -> m r) -- yield
74− -> m r
70+ -> m r
75 }
71 }
76
72
77------------------------------------------------------------------------------
73------------------------------------------------------------------------------
@@ -88,32 +84,14 @@ dbg _ = return ()
88-- Monad
84-- Monad
89------------------------------------------------------------------------------
85------------------------------------------------------------------------------
90
86
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−
106instance MonadAsync m => Monad (AsyncT m) where
87instance MonadAsync m => Monad (AsyncT m) where
107− -- {-# SPECIALIZE instance Monad (AsyncT (StateT Context IO)) #-}
108− {-# SPECIALIZE instance Monad (AsyncT IO) #-}
109 return a = AsyncT $ \_ yld -> yld a Nothing
88 return a = AsyncT $ \_ yld -> yld a Nothing
110
89
111− {-# INLINE (>>=) #-}
112 AsyncT m >>= f = AsyncT $ \stp yld ->
90 AsyncT m >>= f = AsyncT $ \stp yld ->
113− m stp (\a ma ->
91+ m stp (\a r ->
114− case ma of
92+ case r of
115− Just mx -> (runAsyncT (parallel (f a) (mx >>= f))) stp yld
116 Nothing -> (runAsyncT (f a)) stp yld
93 Nothing -> (runAsyncT (f a)) stp yld
94+ Just rx -> (runAsyncT ((f a) <|> (rx >>= f))) stp yld
117 )
95 )
118
96
119------------------------------------------------------------------------------
97------------------------------------------------------------------------------
@@ -153,16 +131,21 @@ instance MonadAsync m => Applicative (AsyncT m) where
153-- they can go away rather than waiting indefinitely.
131-- they can go away rather than waiting indefinitely.
154
132
155instance MonadAsync m => Alternative (AsyncT m) where
133instance MonadAsync m => Alternative (AsyncT m) where
156− -- {-# SPECIALIZE instance Alternative (AsyncT (StateT Context IO)) #-}
157− {-# SPECIALIZE instance Alternative (AsyncT IO) #-}
158 empty = AsyncT $ \stp _ -> stp
134 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+ )
160
144
161instance MonadAsync m => MonadPlus (AsyncT m) where
145instance MonadAsync m => MonadPlus (AsyncT m) where
162 mzero = empty
146 mzero = empty
163 mplus = (<|>)
147 mplus = (<|>)
164
148
165−{-
166instance (Monoid a, MonadAsync m) => Monoid (AsyncT m a) where
149instance (Monoid a, MonadAsync m) => Monoid (AsyncT m a) where
167 mappend x y = mappend <$> x <*> y
150 mappend x y = mappend <$> x <*> y
168 mempty = return mempty
151 mempty = return mempty
@@ -179,7 +162,6 @@ instance (Num a, Monad (AsyncT m)) => Num (AsyncT m a) where
179 abs f = f >>= return . abs
162 abs f = f >>= return . abs
180 signum f = f >>= return . signum
163 signum f = f >>= return . signum
181
164
182−-}
183-------------------------------------------------------------------------------
165-------------------------------------------------------------------------------
184-- AsyncT transformer
166-- AsyncT transformer
185-------------------------------------------------------------------------------
167-------------------------------------------------------------------------------
@@ -238,9 +220,8 @@ instance (MonadAsync m, MonadRecorder m) => MonadRecorder (AsyncT m) where
238{-
220{-
239-- | Run @m a@ before running @m b@. The result of @m a@ is discarded.
221-- | Run @m a@ before running @m b@. The result of @m a@ is discarded.
240before :: MonadAsync m => AsyncT m a -> AsyncT m b -> AsyncT m b
222before :: MonadAsync m => AsyncT m a -> AsyncT m b -> AsyncT m b
241−before ma mb = AsyncT $ do
223+before ma mb = AsyncT $ \stp yld ->
242− _ <- runAsyncT (ma >> mzero)
224+ (runAsyncT ma) ((runAsyncT mb) stp yld) yld
243− runAsyncT mb
244
225
245infixr 1 *>>
226infixr 1 *>>
246-- | Same as 'before'.
227-- | Same as 'before'.
@@ -305,28 +286,3 @@ async action = AsyncT $ runAsyncTask True (runAsyncT action)
305makeAsync :: MonadAsync m => ((a -> m ()) -> m ()) -> AsyncT m a
286makeAsync :: MonadAsync m => ((a -> m ()) -> m ()) -> AsyncT m a
306makeAsync = AsyncT . makeCont
287makeAsync = AsyncT . makeCont
307-}
288-}
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