f8851aa · streamly · git.iko.soy

git.iko.soy/streamly

on master help sign in

Add MonadRecorder instance to AsynclyT

f8851aaHarendra Kumar9 years ago

src/Asyncly/RunAsync.hs+25−17

compare with master

unifiedsplit

@@ -1,8 +1,7 @@

1{-# LANGUAGE FlexibleContexts #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

2+{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE StandaloneDeriving #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE UndecidableInstances #-}

7-- |

6-- |

8-- Module : Asyncly.Threads

7-- Module : Asyncly.Threads

@@ -19,11 +18,12 @@ module Asyncly.RunAsync

19 , toList

18 , toList

20 , each

19 , each

21 , threads

20 , threads

21+

22 {-

23− , waitRecord_

23+ , runAsyclyRecorded

24 , waitRecord

25− , playRecordings

26 -}

25 -}

26+ , playRecordings

27 )

28where

@@ -34,7 +34,7 @@ import Control.Monad.Catch (MonadCatch, MonadThrow, throwM, tr

34import Control.Monad.IO.Class (MonadIO (..))

35import Control.Monad.Trans.Class (MonadTrans (lift))

36import Control.Monad.Trans.Control (MonadBaseControl)

37−import Control.Monad.State (StateT, runStateT)

37+import Control.Monad.State (StateT(..), runStateT)

38import Control.Monad.Trans.Class (MonadTrans (lift))

39import Data.Atomics (atomicModifyIORefCAS)

40import Data.IORef (IORef, newIORef, readIORef)

@@ -53,14 +53,23 @@ import Asyncly.AsyncT

54newtype AsynclyT m a = AsynclyT { runAsynclyT :: AsyncT (StateT Context m) a }

56−deriving instance MonadAsync m => Functor (AsynclyT m)

56+deriving instance Monad m => Functor (AsynclyT m)

57−deriving instance MonadAsync m => Applicative (AsynclyT m)

57+deriving instance Monad m => Applicative (AsynclyT m)

58−deriving instance MonadAsync m => Alternative (AsynclyT m)

58+deriving instance Monad m => Alternative (AsynclyT m)

59−deriving instance MonadAsync m => Monad (AsynclyT m)

59+deriving instance Monad m => Monad (AsynclyT m)

60−deriving instance MonadAsync m => MonadIO (AsynclyT m)

60+deriving instance MonadIO m => MonadIO (AsynclyT m)

61instance MonadTrans (AsynclyT) where

62 lift mx = AsynclyT $ AsyncT $ \s k -> lift mx >>= (\a -> (k a Nothing))

64+instance (Monad m, MonadRecorder m)

65+ => MonadRecorder (StateT Context m) where

66+ getJournal = lift getJournal

67+ putJournal = lift . putJournal

68+ play = lift . play

69+

70+deriving instance (Monad m, MonadRecorder m)

71+ => MonadRecorder (AsynclyT m)

72+

64------------------------------------------------------------------------------

73------------------------------------------------------------------------------

65-- Running the monad

74-- Running the monad

66------------------------------------------------------------------------------

75------------------------------------------------------------------------------

@@ -124,23 +133,23 @@ threads :: MonadAsync m => Int -> AsynclyT m a -> AsynclyT m a

124threads n action = AsynclyT $ AsyncT $ \stp yld ->

133threads n action = AsynclyT $ AsyncT $ \stp yld ->

125 threadCtl n ((runAsyncT $ runAsynclyT action) stp yld)

134 threadCtl n ((runAsyncT $ runAsynclyT action) stp yld)

126

135

127−{-

128------------------------------------------------------------------------------

136------------------------------------------------------------------------------

129-- Logging

137-- Logging

130------------------------------------------------------------------------------

138------------------------------------------------------------------------------

131

139

132-- | Compose a computation using previously captured logs

140-- | Compose a computation using previously captured logs

133playRecording :: (MonadAsync m, MonadRecorder m)

141playRecording :: (MonadAsync m, MonadRecorder m)

134− => AsyncT m a -> Recording -> AsyncT m a

142+ => AsynclyT m a -> Recording -> AsynclyT m a

135playRecording m recording = play recording >> m

143playRecording m recording = play recording >> m

136

144

137-- | Resume an 'AsyncT' computation using previously recorded logs. The

145-- | Resume an 'AsyncT' computation using previously recorded logs. The

138-- recording consists of a list of journals one for each thread in the

146-- recording consists of a list of journals one for each thread in the

139-- computation.

147-- computation.

140playRecordings :: (MonadAsync m, MonadRecorder m)

148playRecordings :: (MonadAsync m, MonadRecorder m)

141− => AsyncT m a -> [Recording] -> AsyncT m a

149+ => AsynclyT m a -> [Recording] -> AsynclyT m a

142playRecordings m logs = each logs >>= playRecording m

150playRecordings m logs = each logs >>= playRecording m

143

151

152+{-

144-- | Run an 'AsyncT' computation with recording enabled, wait for it to finish

153-- | Run an 'AsyncT' computation with recording enabled, wait for it to finish

145-- returning results for completed threads and recordings for paused threads.

154-- returning results for completed threads and recordings for paused threads.

146waitRecord :: (MonadAsync m, MonadCatch m)

155waitRecord :: (MonadAsync m, MonadCatch m)

@@ -156,12 +165,11 @@ waitRecord m = do

156-- | Run an 'AsyncT' computation with recording enabled, wait for it to finish

165-- | Run an 'AsyncT' computation with recording enabled, wait for it to finish

157-- and discard the results and return the recordings for paused threads, if

166-- and discard the results and return the recordings for paused threads, if

158-- any.

167-- any.

159−waitRecord_ :: (MonadAsync m, MonadCatch m)

168+runAsynclyRecorded :: (MonadAsync m, MonadCatch m)

160− => AsyncT (RecorderT m) a -> m [Recording]

169+ => AsynclyT (RecorderT m) a -> m [Recording]

161−waitRecord_ m = do

170+runAsynclyRecorded m = do

162 lref <- liftIO $ newIORef []

171 lref <- liftIO $ newIORef []

163 runRecorderT blank (waitAsync (const (return Nothing)) (Just lref) m)

172 runRecorderT blank (waitAsync (const (return Nothing)) (Just lref) m)

164 logs <- liftIO $ readIORef lref

173 logs <- liftIO $ readIORef lref

165 return logs

174 return logs

166−

167-}

175-}

test/logged.hs+5−4

@@ -8,13 +8,13 @@ import Control.Monad.Trans.Recorder (pause, record)

9main = do

10 hSetBuffering stdout LineBuffering

11− logs <- waitRecord_ comp

11+ logs <- runAsynclyRecorded comp

13 putStrLn $ "\nResuming with logs:"

14− logs1 <- waitRecord_ $ playRecordings comp logs

14+ logs1 <- runAsynclyRecorded $ playRecordings comp logs

16 putStrLn $ "\nResuming with logs:"

17− logs2 <- waitRecord_ $ playRecordings comp logs1

17+ logs2 <- runAsynclyRecorded $ playRecordings comp logs1

19 putStrLn $ "\nLogs at the end must be empty:"

20 putStrLn $ show logs2

@@ -30,4 +30,5 @@ main = do

30 record pause

31 liftIO $ print ("C", r, x)

33− event n = async $ liftIO $ (do putStrLn ("event" ++ show n); return n :: IO Int)

33+ -- event n = async $ liftIO $ (do putStrLn ("event" ++ show n); return n :: IO Int)

34+ event n = liftIO $ (do putStrLn ("event" ++ show n); return n :: IO Int)