@@ -1,14 +1,7 @@
1−{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE ExistentialQuantification #-}
31{-# LANGUAGE FlexibleContexts #-}
42{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE InstanceSigs #-}
63{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE Rank2Types #-}
8−{-# LANGUAGE RecordWildCards #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE UndecidableInstances #-}
4+{-# LANGUAGE RankNTypes #-}
125
136-- |
147-- Module : Asyncly.AsyncT
@@ -24,34 +17,27 @@ module Asyncly.AsyncT
2417 ( AsyncT (..)
2518-- , async
2619-- , makeAsync
27−
28− -- internal
29− , dbg
3020 )
3121where
3222
3323import Control.Applicative (Alternative (..))
34−import Control.Monad (ap, mzero, when)
35−import Control.Monad.Base (MonadBase (..), liftBaseDefault)
24+import Control.Monad (ap, liftM, MonadPlus(..), mzero)
25+--import Control.Monad.Base (MonadBase (..), liftBaseDefault)
3626import Control.Monad.Catch (MonadThrow, throwM)
37−import Control.Monad.State (MonadIO (..), MonadPlus (..),
38− StateT (..), liftM, runStateT,
39− get, gets, put, modify)
27+import Control.Monad.IO.Class (MonadIO(..))
4028import Control.Monad.Trans.Class (MonadTrans (lift))
29+{-
4130import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
4231 MonadTransControl (..),
4332 defaultLiftBaseWith,
4433 defaultRestoreM, liftBaseWith)
34+ -}
4535import Data.Maybe (maybe)
46−import Data.IORef (newIORef, readIORef, writeIORef)
47−import Unsafe.Coerce (unsafeCoerce)
4836
4937import Control.Monad.Trans.Recorder (MonadRecorder(..))
50−--import Debug.Trace (traceM)
38+--import Asyncly.Threads (MonadAsync)
5139
52−import Asyncly.Threads (MonadAsync, Context)
53−
54−-- The 'Maybe' is redundant as we can use 'stop' value in place of Nothing,
40+-- The 'Maybe' is redundant as we can use 'stop' value in the Nothing case,
5541-- but it makes the fold using '<|>' 25% faster.
5642newtype AsyncT m a =
5743 AsyncT {
@@ -61,42 +47,30 @@ newtype AsyncT m a =
6147 -> m r
6248 }
6349
64−------------------------------------------------------------------------------
65−-- Utilities
66−------------------------------------------------------------------------------
67−
68−-- Toggle the dbg definition for debug traces
69−--dbg :: Monad m => String -> m ()
70−--dbg = traceM
71−dbg :: Monad m => a -> m ()
72−dbg _ = return ()
73−
7450------------------------------------------------------------------------------
7551-- Monad
7652------------------------------------------------------------------------------
7753
78−instance MonadAsync m => Monad (AsyncT m) where
54+instance Monad m => Monad (AsyncT m) where
7955 return a = AsyncT $ \_ yld -> yld a Nothing
8056
8157 AsyncT m >>= f = AsyncT $ \stp yld ->
82− m stp (\a r ->
83− case r of
84− Nothing -> (runAsyncT (f a)) stp yld
85− Just rx -> (runAsyncT ((f a) <|> (rx >>= f))) stp yld
86− )
58+ let run x = (runAsyncT x) stp yld
59+ in m stp $ \a r ->
60+ maybe (run $ f a) (\rx -> run $ f a <|> (rx >>= f)) r
8761
8862------------------------------------------------------------------------------
8963-- Functor
9064------------------------------------------------------------------------------
9165
92−instance MonadAsync m => Functor (AsyncT m) where
66+instance Monad m => Functor (AsyncT m) where
9367 fmap = liftM
9468
9569------------------------------------------------------------------------------
9670-- Applicative
9771------------------------------------------------------------------------------
9872
99−instance MonadAsync m => Applicative (AsyncT m) where
73+instance Monad m => Applicative (AsyncT m) where
10074 pure = return
10175 (<*>) = ap
10276
@@ -104,40 +78,21 @@ instance MonadAsync m => Applicative (AsyncT m) where
10478-- Alternative
10579------------------------------------------------------------------------------
10680
107−-- Thread pool vs transient threads
108−--
109−-- The current model is to start a new thread for every task. The computation
110−-- input is provided at the time of the creation and therefore no
111−-- synchronization is needed compared to a pool of threads contending to get
112−-- the input from a channel. However the thread creation overhead may be more
113−-- than the synchronization cost needed in the case of pool?
114−--
115−-- When the task is over, the outputs need to be collected and that requires
116−-- synchronization irrespective of a thread pool model or per task new thread
117−-- model.
118−--
119−-- XXX instead of starting a new thread every time, reuse the existing child
120−-- threads and send them work via a shared channel. When there is no more work
121−-- available we need a way to close the channel and wakeup all waiters so that
122−-- they can go away rather than waiting indefinitely.
123−
124−instance MonadAsync m => Alternative (AsyncT m) where
81+instance Monad m => Alternative (AsyncT m) where
12582 empty = AsyncT $ \stp _ -> stp
12683
12784 -- XXX need to wait for the async threads in case of a stop is returned due
12885 -- to async thread spawning.
12986 AsyncT m1 <|> m2 = AsyncT $ \stp yld ->
130− m1 ((runAsyncT m2) stp yld) (\a r ->
131− case r of
132− Nothing -> yld a (Just m2)
133− Just rx -> yld a (Just (rx <|> m2))
134− )
87+ m1 ((runAsyncT m2) stp yld) $ \a r ->
88+ let yield x = yld a (Just x)
89+ in maybe (yield m2) (\rx -> yield $ rx <|> m2) r
13590
136−instance MonadAsync m => MonadPlus (AsyncT m) where
91+instance Monad m => MonadPlus (AsyncT m) where
13792 mzero = empty
13893 mplus = (<|>)
13994
140−instance (Monoid a, MonadAsync m) => Monoid (AsyncT m a) where
95+instance (Monoid a, Monad m) => Monoid (AsyncT m a) where
14196 mappend x y = mappend <$> x <*> y
14297 mempty = return mempty
14398
@@ -160,14 +115,14 @@ instance (Num a, Monad (AsyncT m)) => Num (AsyncT m a) where
160115instance MonadTrans AsyncT where
161116 lift mx = AsyncT $ \_ yld -> mx >>= (\a -> (yld a Nothing))
162117
163−instance (MonadBase b m, MonadAsync m) => MonadBase b (AsyncT m) where
118+{-
119+instance (MonadBase b m, Monad m) => MonadBase b (AsyncT m) where
164120 liftBase = liftBaseDefault
165121
166122-------------------------------------------------------------------------------
167123-- monad-control
168124-------------------------------------------------------------------------------
169125
170−{-
171126instance MonadTransControl AsyncT where
172127 type StT AsyncT a = (Maybe a, Context)
173128 liftWith f = AsyncT $ StateT $ \s ->
@@ -177,7 +132,7 @@ instance MonadTransControl AsyncT where
177132 {-# INLINABLE liftWith #-}
178133 {-# INLINABLE restoreT #-}
179134
180−instance (MonadBaseControl b m, MonadAsync m) => MonadBaseControl b (AsyncT m) where
135+instance (MonadBaseControl b m, Monad m) => MonadBaseControl b (AsyncT m) where
181136 type StM (AsyncT m) a = ComposeSt AsyncT m a
182137 liftBaseWith = defaultLiftBaseWith
183138 restoreM = defaultRestoreM
@@ -189,17 +144,17 @@ instance (MonadBaseControl b m, MonadAsync m) => MonadBaseControl b (AsyncT m) w
189144-- Standard transformer instances
190145------------------------------------------------------------------------------
191146
192−instance MonadAsync m => MonadIO (AsyncT m) where
147+instance MonadIO m => MonadIO (AsyncT m) where
193148 liftIO = lift . liftIO
194149
195−instance MonadAsync m => MonadThrow (AsyncT m) where
150+instance MonadThrow m => MonadThrow (AsyncT m) where
196151 throwM = lift . throwM
197152
198153------------------------------------------------------------------------------
199154-- MonadRecorder
200155------------------------------------------------------------------------------
201156
202−instance (MonadAsync m, MonadRecorder m) => MonadRecorder (AsyncT m) where
157+instance (Monad m, MonadRecorder m) => MonadRecorder (AsyncT m) where
203158 getJournal = lift getJournal
204159 putJournal = lift . putJournal
205160 play = lift . play
@@ -227,9 +182,9 @@ instance (MonadAsync m, MonadRecorder m) => MonadRecorder (AsyncT m) where
227182-- 'async' is not useful as the last action as the last action always runs in
228183-- the current thread.
229184{-
230−async :: MonadAsync m => AsyncT m a -> AsyncT m a
185+async :: Monad m => AsyncT m a -> AsyncT m a
231186async action = AsyncT $ runAsyncTask True (runAsyncT action)
232187
233−makeAsync :: MonadAsync m => ((a -> m ()) -> m ()) -> AsyncT m a
188+makeAsync :: Monad m => ((a -> m ()) -> m ()) -> AsyncT m a
234189makeAsync = AsyncT . makeCont
235190-}