@@ -18,11 +18,8 @@ module Asyncly.RunAsync
21−
21+ , runAsynclyRecorded
22− {-
22+-- , toListRecorded
26 , playRecordings
23 , playRecordings
@@ -30,19 +27,14 @@ where
30import Control.Applicative (Alternative (..))
27import Control.Applicative (Alternative (..))
31import Control.Concurrent.STM (atomically, newTChan)
28import Control.Concurrent.STM (atomically, newTChan)
32import Control.Monad (liftM)
29import Control.Monad (liftM)
33−import Control.Monad.Catch (MonadCatch, MonadThrow, throwM, try)
30+import Control.Monad.Catch (MonadThrow)
34import Control.Monad.IO.Class (MonadIO (..))
31import Control.Monad.IO.Class (MonadIO (..))
35import Control.Monad.Trans.Class (MonadTrans (lift))
32import Control.Monad.Trans.Class (MonadTrans (lift))
36−import Control.Monad.Trans.Control (MonadBaseControl)
37import Control.Monad.State (StateT(..), runStateT)
33import Control.Monad.State (StateT(..), runStateT)
38−import Control.Monad.Trans.Class (MonadTrans (lift))
39−import Data.Atomics (atomicModifyIORefCAS)
40import Data.IORef (IORef, newIORef, readIORef)
34import Data.IORef (IORef, newIORef, readIORef)
42import Control.Monad.Trans.Recorder (MonadRecorder(..), RecorderT,
36import Control.Monad.Trans.Recorder (MonadRecorder(..), RecorderT,
43 Recording, blank, runRecorderT)
37 Recording, blank, runRecorderT)
46import Asyncly.Threads
38import Asyncly.Threads
47import Asyncly.AsyncT
39import Asyncly.AsyncT
@@ -58,9 +50,11 @@ deriving instance Monad m => Applicative (AsynclyT m)
58deriving instance Monad m => Alternative (AsynclyT m)
50deriving instance Monad m => Alternative (AsynclyT m)
59deriving instance Monad m => Monad (AsynclyT m)
51deriving instance Monad m => Monad (AsynclyT m)
60deriving instance MonadIO m => MonadIO (AsynclyT m)
52deriving instance MonadIO m => MonadIO (AsynclyT m)
53+deriving instance MonadThrow m => MonadThrow (AsynclyT m)
61instance MonadTrans (AsynclyT) where
54instance MonadTrans (AsynclyT) where
62− lift mx = AsynclyT $ AsyncT $ \s k -> lift mx >>= (\a -> (k a Nothing))
55+ lift mx = AsynclyT $ AsyncT $ \_ k -> lift mx >>= (\a -> (k a Nothing))
57+-- XXX orphan instance, use a newtype instead?
64instance (Monad m, MonadRecorder m)
58instance (Monad m, MonadRecorder m)
65 => MonadRecorder (StateT Context m) where
59 => MonadRecorder (StateT Context m) where
66 getJournal = lift getJournal
60 getJournal = lift getJournal
@@ -83,24 +77,28 @@ getContext lref = do
84-- | Run an 'AsynclyT m' computation, wait for it to finish and discard the
78-- | Run an 'AsynclyT m' computation, wait for it to finish and discard the
85-- results.
79-- results.
86−{-# INLINABLE runAsyncly #-}
80+{-# INLINABLE runAsynclyLogged #-}
87−runAsyncly :: (MonadAsync m, MonadCatch m) => AsynclyT m a -> m ()
81+runAsynclyLogged :: MonadAsync m
82+ => Maybe (IORef [Recording]) -> AsynclyT m a -> m ()
88−runAsyncly (AsynclyT m) = do
83+runAsynclyLogged lref (AsynclyT m) = do
89− ctx <- liftIO $ getContext Nothing
84+ ctx <- liftIO $ getContext lref
90 _ <- runStateT (run m) ctx
85 _ <- runStateT (run m) ctx
95 stop = return ()
90 stop = return ()
96− run m = (runAsyncT m) stop (\_ r -> maybe stop run r)
91+ run mx = (runAsyncT mx) stop (\_ r -> maybe stop run r)
93+runAsyncly :: MonadAsync m => AsynclyT m a -> m ()
94+runAsyncly m = runAsynclyLogged Nothing m
98data Step a r = Stop | Done a | Yield a r
96data Step a r = Stop | Done a | Yield a r
100-- | Run an 'AsynclyT m' computation and collect the results generated by each
98-- | Run an 'AsynclyT m' computation and collect the results generated by each
101-- thread of the computation in a list.
99-- thread of the computation in a list.
102{-# INLINABLE toList #-}
100{-# INLINABLE toList #-}
103−toList :: (MonadAsync m, MonadCatch m) => AsynclyT m a -> m [a]
101+toList :: MonadAsync m => AsynclyT m a -> m [a]
104toList (AsynclyT m) = liftIO (getContext Nothing) >>= run m
102toList (AsynclyT m) = liftIO (getContext Nothing) >>= run m
@@ -152,24 +150,23 @@ playRecordings m logs = each logs >>= playRecording m
153-- | Run an 'AsyncT' computation with recording enabled, wait for it to finish
151-- | Run an 'AsyncT' computation with recording enabled, wait for it to finish
154-- returning results for completed threads and recordings for paused threads.
152-- returning results for completed threads and recordings for paused threads.
155−waitRecord :: (MonadAsync m, MonadCatch m)
153+toListRecorded :: (MonadAsync m, MonadCatch m)
156− => AsyncT m a -> m ([a], [Recording])
154+ => AsynclyT m a -> m ([a], [Recording])
157−waitRecord m = do
155+toListRecorded m = do
158 resultsRef <- liftIO $ newIORef []
156 resultsRef <- liftIO $ newIORef []
159 lref <- liftIO $ newIORef []
157 lref <- liftIO $ newIORef []
160 waitAsync (gatherResult resultsRef) (Just lref) m
158 waitAsync (gatherResult resultsRef) (Just lref) m
161 res <- liftIO $ readIORef resultsRef
159 res <- liftIO $ readIORef resultsRef
162 logs <- liftIO $ readIORef lref
160 logs <- liftIO $ readIORef lref
163 return (res, logs)
161 return (res, logs)
165-- | Run an 'AsyncT' computation with recording enabled, wait for it to finish
164-- | Run an 'AsyncT' computation with recording enabled, wait for it to finish
166-- and discard the results and return the recordings for paused threads, if
165-- and discard the results and return the recordings for paused threads, if
168−runAsynclyRecorded :: (MonadAsync m, MonadCatch m)
169− => AsynclyT (RecorderT m) a -> m [Recording]
167+runAsynclyRecorded :: MonadAsync m => AsynclyT (RecorderT m) a -> m [Recording]
170runAsynclyRecorded m = do
168runAsynclyRecorded m = do
171 lref <- liftIO $ newIORef []
169 lref <- liftIO $ newIORef []
172− runRecorderT blank (waitAsync (const (return Nothing)) (Just lref) m)
170+ runRecorderT blank (runAsynclyLogged (Just lref) m)
173 logs <- liftIO $ readIORef lref
171 logs <- liftIO $ readIORef lref
174 return logs
172 return logs