git.iko.soy/streamly
on master help sign in
Pass context directly, removing the use of State monad
c9b9ab3Harendra Kumar
src/Asyncly/AsyncT.hs+17−16
compare with master
unifiedsplit
@@ -35,15 +35,16 @@ import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
35import Data.Maybe (maybe)
35import Data.Maybe (maybe)
36
36
37import Control.Monad.Trans.Recorder (MonadRecorder(..))
37import Control.Monad.Trans.Recorder (MonadRecorder(..))
38−--import Asyncly.Threads (MonadAsync)
38+import Asyncly.Threads (Context)
39
39
40-- The 'Maybe' is redundant as we can use 'stop' value in the Nothing case,
40-- The 'Maybe' is redundant as we can use 'stop' value in the Nothing case,
41-- but it makes the fold using '<|>' 25% faster.
41-- but it makes the fold using '<|>' 25% faster.
42newtype AsyncT m a =
42newtype AsyncT m a =
43 AsyncT {
43 AsyncT {
44 runAsyncT :: forall r.
44 runAsyncT :: forall r.
45+ Context -- state
45− m r -- stop
46+ -> m r -- stop
46− -> (a -> Maybe (AsyncT m a) -> m r) -- yield
47+ -> (a -> Context -> Maybe (AsyncT m a) -> m r) -- yield
47 -> m r
48 -> m r
48 }
49 }
49
50
@@ -62,18 +63,18 @@ newtype AsyncT m a =
62-- efficient. Maybe sometime we shall be able to do that?
63-- efficient. Maybe sometime we shall be able to do that?
63
64
64serially :: AsyncT m a -> AsyncT m a -> AsyncT m a
65serially :: AsyncT m a -> AsyncT m a -> AsyncT m a
65−serially (AsyncT m1) m2 = AsyncT $ \stp yld ->
66+serially (AsyncT m1) m2 = AsyncT $ \ctx stp yld ->
66− m1 ((runAsyncT m2) stp yld) $ \a r ->
67+ m1 ctx ((runAsyncT m2) ctx stp yld) $ \a c r ->
67− let yield x = yld a (Just x)
68+ let yield x = yld a c (Just x)
68 in maybe (yield m2) (\rx -> yield $ serially rx m2) r
69 in maybe (yield m2) (\rx -> yield $ serially rx m2) r
69
70
70instance Monad m => Monad (AsyncT m) where
71instance Monad m => Monad (AsyncT m) where
71− return a = AsyncT $ \_ yld -> yld a Nothing
72+ return a = AsyncT $ \ctx _ yld -> yld a ctx Nothing
72
73
73− AsyncT m >>= f = AsyncT $ \stp yld ->
74+ AsyncT m >>= f = AsyncT $ \ctx stp yld ->
75+ m ctx stp $ \a c r ->
74− let run x = (runAsyncT x) stp yld
76+ let run x = (runAsyncT x) c stp yld
75− in m stp $ \a r ->
76− maybe (run $ f a) (\rx -> run $ serially (f a) (rx >>= f)) r
77+ in maybe (run $ f a) (\rx -> run $ serially (f a) (rx >>= f)) r
77
78
78------------------------------------------------------------------------------
79------------------------------------------------------------------------------
79-- Functor
80-- Functor
@@ -95,13 +96,13 @@ instance Monad m => Applicative (AsyncT m) where
95------------------------------------------------------------------------------
96------------------------------------------------------------------------------
96
97
97instance Monad m => Alternative (AsyncT m) where
98instance Monad m => Alternative (AsyncT m) where
98− empty = AsyncT $ \stp _ -> stp
99+ empty = AsyncT $ \_ stp _ -> stp
99
100
100 -- XXX need to wait for the async threads in case of a stop is returned due
101 -- XXX need to wait for the async threads in case of a stop is returned due
101 -- to async thread spawning.
102 -- to async thread spawning.
102− AsyncT m1 <|> m2 = AsyncT $ \stp yld ->
103+ AsyncT m1 <|> m2 = AsyncT $ \ctx stp yld ->
103− m1 ((runAsyncT m2) stp yld) $ \a r ->
104+ m1 ctx ((runAsyncT m2) ctx stp yld) $ \a c r ->
104− let yield x = yld a (Just x)
105+ let yield x = yld a c (Just x)
105 in maybe (yield m2) (\rx -> yield $ rx <|> m2) r
106 in maybe (yield m2) (\rx -> yield $ rx <|> m2) r
106
107
107instance Monad m => MonadPlus (AsyncT m) where
108instance Monad m => MonadPlus (AsyncT m) where
@@ -129,7 +130,7 @@ instance (Num a, Monad (AsyncT m)) => Num (AsyncT m a) where
129-------------------------------------------------------------------------------
130-------------------------------------------------------------------------------
130
131
131instance MonadTrans AsyncT where
132instance 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))
133
134
134{-
135{-
135instance (MonadBase b m, Monad m) => MonadBase b (AsyncT m) where
136instance (MonadBase b m, Monad m) => MonadBase b (AsyncT m) where
src/Asyncly/RunAsync.hs+21−15
@@ -43,6 +43,7 @@ import Asyncly.AsyncT
43-- results in 2x performance degradation. At some point if that performance is
43-- results in 2x performance degradation. At some point if that performance is
44-- really needed we can combine the two.
44-- really needed we can combine the two.
45
45
46+{-
46newtype AsynclyT m a = AsynclyT { runAsynclyT :: AsyncT (StateT Context m) a }
47newtype AsynclyT m a = AsynclyT { runAsynclyT :: AsyncT (StateT Context m) a }
47
48
48deriving instance Monad m => Functor (AsynclyT m)
49deriving instance Monad m => Functor (AsynclyT m)
@@ -52,7 +53,7 @@ deriving instance Monad m => Monad (AsynclyT m)
52deriving instance MonadIO m => MonadIO (AsynclyT m)
53deriving instance MonadIO m => MonadIO (AsynclyT m)
53deriving instance MonadThrow m => MonadThrow (AsynclyT m)
54deriving instance MonadThrow m => MonadThrow (AsynclyT m)
54instance MonadTrans (AsynclyT) where
55instance 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))
56
57
57-- XXX orphan instance, use a newtype instead?
58-- XXX orphan instance, use a newtype instead?
58instance (Monad m, MonadRecorder m)
59instance (Monad m, MonadRecorder m)
@@ -64,6 +65,10 @@ instance (Monad m, MonadRecorder m)
64deriving instance (Monad m, MonadRecorder m)
65deriving instance (Monad m, MonadRecorder m)
65 => MonadRecorder (AsynclyT m)
66 => MonadRecorder (AsynclyT m)
66
67
68+-}
69+
70+type AsynclyT = AsyncT
71+
67------------------------------------------------------------------------------
72------------------------------------------------------------------------------
68-- Running the monad
73-- Running the monad
69------------------------------------------------------------------------------
74------------------------------------------------------------------------------
@@ -80,39 +85,40 @@ getContext lref = do
80{-# INLINABLE runAsynclyLogged #-}
85{-# INLINABLE runAsynclyLogged #-}
81runAsynclyLogged :: MonadAsync m
86runAsynclyLogged :: MonadAsync m
82 => Maybe (IORef [Recording]) -> AsynclyT m a -> m ()
87 => Maybe (IORef [Recording]) -> AsynclyT m a -> m ()
83−runAsynclyLogged lref (AsynclyT m) = do
88+runAsynclyLogged lref m = do
84 ctx <- liftIO $ getContext lref
89 ctx <- liftIO $ getContext lref
85− _ <- runStateT (run m) ctx
90+ run ctx m
86− return ()
87
91
88 where
92 where
89
93
90 stop = return ()
94 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)
92
97
93runAsyncly :: MonadAsync m => AsynclyT m a -> m ()
98runAsyncly :: MonadAsync m => AsynclyT m a -> m ()
94runAsyncly m = runAsynclyLogged Nothing m
99runAsyncly m = runAsynclyLogged Nothing m
95
100
96−data Step a r = Stop | Done a | Yield a r
101+data Step a r = Stop | Done a | Yield a Context r
97
102
98-- | Run an 'AsynclyT m' computation and collect the results generated by each
103-- | Run an 'AsynclyT m' computation and collect the results generated by each
99-- thread of the computation in a list.
104-- thread of the computation in a list.
100{-# INLINABLE toList #-}
105{-# INLINABLE toList #-}
101toList :: MonadAsync m => AsynclyT m a -> m [a]
106toList :: MonadAsync m => AsynclyT m a -> m [a]
107+toList m = do
102−toList (AsynclyT m) = liftIO (getContext Nothing) >>= run m
108+ ctx <- liftIO (getContext Nothing)
109+ run ctx m
103
110
104 where
111 where
105
112
106 stop = return Stop
113 stop = return Stop
107 done a = return (Done a)
114 done a = return (Done a)
108− yield a x = return $ Yield a x
115+ yield a c x = return $ Yield a c x
109
116
110− run ma ctx = do
117+ run ctx ma = do
111− (res, ctx') <- runStateT
118+ res <- (runAsyncT ma) ctx stop (\a c r ->
112− ((runAsyncT ma) stop (\a r -> maybe (done a) (\x -> yield a x) r))
119+ maybe (done a) (\x -> yield a c x) r)
113− ctx
114 case res of
120 case res of
115− Yield x mb -> liftM (x :) (run mb ctx')
121+ Yield x c mb -> liftM (x :) (run c mb)
116 Stop -> return []
122 Stop -> return []
117 Done x -> return (x : [])
123 Done x -> return (x : [])
118
124
@@ -128,8 +134,8 @@ each xs = foldr (<|>) empty $ map return xs
128-- tasks start synchronously in the current thread unless overridden by
134-- tasks start synchronously in the current thread unless overridden by
129-- 'async'.
135-- 'async'.
130threads :: MonadAsync m => Int -> AsynclyT m a -> AsynclyT m a
136threads :: MonadAsync m => Int -> AsynclyT m a -> AsynclyT m a
131−threads n action = AsynclyT $ AsyncT $ \stp yld ->
137+threads n action = AsyncT $ \ctx stp yld ->
132− threadCtl n ((runAsyncT $ runAsynclyT action) stp yld)
138+ (runAsyncT action) ctx stp yld
133
139
134------------------------------------------------------------------------------
140------------------------------------------------------------------------------
135-- Logging
141-- Logging