git.iko.soy/streamly
on master help sign in
Pass context directly, removing the use of State monad
commitc9b9ab35dbd3c7f138e0e1ef81945cd5bfce8285 authorHarendra Kumar <harendra.kumar@gmail.com> dateFri 11 Aug 2017, 12:59 (9 years ago) parent6935930
2 files changed+38−31
compare with master
unifiedsplit
src/Asyncly/AsyncT.hs+17−16 src/Asyncly/RunAsync.hs+21−15
src/Asyncly/AsyncT.hs+17−16
@@ -35,15 +35,16 @@ import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
3535import Data.Maybe (maybe)
3636
3737import Control.Monad.Trans.Recorder (MonadRecorder(..))
38−--import Asyncly.Threads (MonadAsync)
38+import Asyncly.Threads (Context)
3939
4040-- The 'Maybe' is redundant as we can use 'stop' value in the Nothing case,
4141-- but it makes the fold using '<|>' 25% faster.
4242newtype AsyncT m a =
4343 AsyncT {
4444 runAsyncT :: forall r.
45− m r -- stop
46− -> (a -> Maybe (AsyncT m a) -> m r) -- yield
45+ Context -- state
46+ -> m r -- stop
47+ -> (a -> Context -> Maybe (AsyncT m a) -> m r) -- yield
4748 -> m r
4849 }
4950
@@ -62,18 +63,18 @@ newtype AsyncT m a =
6263-- efficient. Maybe sometime we shall be able to do that?
6364
6465serially :: AsyncT m a -> AsyncT m a -> AsyncT m a
65−serially (AsyncT m1) m2 = AsyncT $ \stp yld ->
66− m1 ((runAsyncT m2) stp yld) $ \a r ->
67− let yield x = yld a (Just x)
66+serially (AsyncT m1) m2 = AsyncT $ \ctx stp yld ->
67+ m1 ctx ((runAsyncT m2) ctx stp yld) $ \a c r ->
68+ let yield x = yld a c (Just x)
6869 in maybe (yield m2) (\rx -> yield $ serially rx m2) r
6970
7071instance Monad m => Monad (AsyncT m) where
71− return a = AsyncT $ \_ yld -> yld a Nothing
72+ return a = AsyncT $ \ctx _ yld -> yld a ctx Nothing
7273
73− AsyncT m >>= f = AsyncT $ \stp yld ->
74− let run x = (runAsyncT x) stp yld
75− in m stp $ \a r ->
76− maybe (run $ f a) (\rx -> run $ serially (f a) (rx >>= f)) r
74+ AsyncT m >>= f = AsyncT $ \ctx stp yld ->
75+ m ctx stp $ \a c r ->
76+ let run x = (runAsyncT x) c stp yld
77+ in maybe (run $ f a) (\rx -> run $ serially (f a) (rx >>= f)) r
7778
7879------------------------------------------------------------------------------
7980-- Functor
@@ -95,13 +96,13 @@ instance Monad m => Applicative (AsyncT m) where
9596------------------------------------------------------------------------------
9697
9798instance Monad m => Alternative (AsyncT m) where
98− empty = AsyncT $ \stp _ -> stp
99+ empty = AsyncT $ \_ stp _ -> stp
99100
100101 -- XXX need to wait for the async threads in case of a stop is returned due
101102 -- to async thread spawning.
102− AsyncT m1 <|> m2 = AsyncT $ \stp yld ->
103− m1 ((runAsyncT m2) stp yld) $ \a r ->
104− let yield x = yld a (Just x)
103+ AsyncT m1 <|> m2 = AsyncT $ \ctx stp yld ->
104+ m1 ctx ((runAsyncT m2) ctx stp yld) $ \a c r ->
105+ let yield x = yld a c (Just x)
105106 in maybe (yield m2) (\rx -> yield $ rx <|> m2) r
106107
107108instance Monad m => MonadPlus (AsyncT m) where
@@ -129,7 +130,7 @@ instance (Num a, Monad (AsyncT m)) => Num (AsyncT m a) where
129130-------------------------------------------------------------------------------
130131
131132instance MonadTrans AsyncT where
132− lift mx = AsyncT $ \_ yld -> mx >>= (\a -> (yld a Nothing))
133+ lift mx = AsyncT $ \ctx _ yld -> mx >>= (\a -> (yld a ctx Nothing))
133134
134135{-
135136instance (MonadBase b m, Monad m) => MonadBase b (AsyncT m) where
src/Asyncly/RunAsync.hs+21−15
@@ -43,6 +43,7 @@ import Asyncly.AsyncT
4343-- results in 2x performance degradation. At some point if that performance is
4444-- really needed we can combine the two.
4545
46+{-
4647newtype AsynclyT m a = AsynclyT { runAsynclyT :: AsyncT (StateT Context m) a }
4748
4849deriving instance Monad m => Functor (AsynclyT m)
@@ -52,7 +53,7 @@ deriving instance Monad m => Monad (AsynclyT m)
5253deriving instance MonadIO m => MonadIO (AsynclyT m)
5354deriving instance MonadThrow m => MonadThrow (AsynclyT m)
5455instance MonadTrans (AsynclyT) where
55− lift mx = AsynclyT $ AsyncT $ \_ k -> lift mx >>= (\a -> (k a Nothing))
56+ lift mx = AsynclyT $ AsyncT $ \c _ k -> lift mx >>= (\a -> (k a c Nothing))
5657
5758-- XXX orphan instance, use a newtype instead?
5859instance (Monad m, MonadRecorder m)
@@ -64,6 +65,10 @@ instance (Monad m, MonadRecorder m)
6465deriving instance (Monad m, MonadRecorder m)
6566 => MonadRecorder (AsynclyT m)
6667
68+-}
69+
70+type AsynclyT = AsyncT
71+
6772------------------------------------------------------------------------------
6873-- Running the monad
6974------------------------------------------------------------------------------
@@ -80,39 +85,40 @@ getContext lref = do
8085{-# INLINABLE runAsynclyLogged #-}
8186runAsynclyLogged :: MonadAsync m
8287 => Maybe (IORef [Recording]) -> AsynclyT m a -> m ()
83−runAsynclyLogged lref (AsynclyT m) = do
88+runAsynclyLogged lref m = do
8489 ctx <- liftIO $ getContext lref
85− _ <- runStateT (run m) ctx
86− return ()
90+ run ctx m
8791
8892 where
8993
9094 stop = return ()
91− run mx = (runAsyncT mx) stop (\_ r -> maybe stop run r)
95+ run ct mx = (runAsyncT mx) ct stop (\_ ct r ->
96+ maybe stop (\x -> (run ct x)) r)
9297
9398runAsyncly :: MonadAsync m => AsynclyT m a -> m ()
9499runAsyncly m = runAsynclyLogged Nothing m
95100
96−data Step a r = Stop | Done a | Yield a r
101+data Step a r = Stop | Done a | Yield a Context r
97102
98103-- | Run an 'AsynclyT m' computation and collect the results generated by each
99104-- thread of the computation in a list.
100105{-# INLINABLE toList #-}
101106toList :: MonadAsync m => AsynclyT m a -> m [a]
102−toList (AsynclyT m) = liftIO (getContext Nothing) >>= run m
107+toList m = do
108+ ctx <- liftIO (getContext Nothing)
109+ run ctx m
103110
104111 where
105112
106113 stop = return Stop
107114 done a = return (Done a)
108− yield a x = return $ Yield a x
115+ yield a c x = return $ Yield a c x
109116
110− run ma ctx = do
111− (res, ctx') <- runStateT
112− ((runAsyncT ma) stop (\a r -> maybe (done a) (\x -> yield a x) r))
113− ctx
117+ run ctx ma = do
118+ res <- (runAsyncT ma) ctx stop (\a c r ->
119+ maybe (done a) (\x -> yield a c x) r)
114120 case res of
115− Yield x mb -> liftM (x :) (run mb ctx')
121+ Yield x c mb -> liftM (x :) (run c mb)
116122 Stop -> return []
117123 Done x -> return (x : [])
118124
@@ -128,8 +134,8 @@ each xs = foldr (<|>) empty $ map return xs
128134-- tasks start synchronously in the current thread unless overridden by
129135-- 'async'.
130136threads :: MonadAsync m => Int -> AsynclyT m a -> AsynclyT m a
131−threads n action = AsynclyT $ AsyncT $ \stp yld ->
132− threadCtl n ((runAsyncT $ runAsynclyT action) stp yld)
137+threads n action = AsyncT $ \ctx stp yld ->
138+ (runAsyncT action) ctx stp yld
133139
134140------------------------------------------------------------------------------
135141-- Logging