@@ -24,8 +24,8 @@ module Asyncly.AsyncT
2424 ( AsyncT (..)
2525
2626 , threads
27− , async
28− , makeAsync
27+-- , async
28+-- , makeAsync
2929 , each
3030
3131 , before
@@ -46,7 +46,7 @@ import Control.Monad.Base (MonadBase (..), liftBaseDefault)
4646import Control.Monad.Catch (MonadThrow, throwM)
4747import Control.Monad.State (MonadIO (..), MonadPlus (..),
4848 StateT (..), liftM, runStateT,
49− modify)
49+ get, gets, put, modify)
5050import Control.Monad.Trans.Class (MonadTrans (lift))
5151import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
5252 MonadTransControl (..),
@@ -60,7 +60,8 @@ import Control.Monad.Trans.Recorder (MonadRecorder(..))
6060
6161import Asyncly.Threads
6262
63−newtype AsyncT m a = AsyncT { runAsyncT :: StateT Context m (Maybe a) }
63+--data Step a m = Stop | Yield a (AsyncT m a)
64+--newtype AsyncT m a = AsyncT { runAsyncT :: StateT Context m (Step a m) }
6465
6566------------------------------------------------------------------------------
6667-- Utilities
@@ -76,23 +77,38 @@ dbg _ = return ()
7677-- Monad
7778------------------------------------------------------------------------------
7879
80+stop :: Monad m => AsyncT m a
81+stop = AsyncT . return $ Stop
82+
83+{-# SPECIALIZE runAction :: AsyncT IO a -> StateT Context IO (Step a IO) #-}
84+runAction :: Monad m => AsyncT m a -> StateT Context m (Step a m)
85+runAction m = do
86+ ctx <- get
87+ (step, ctx') <- lift $ runStateT (runAsyncT m) ctx
88+ put ctx'
89+ return step
90+
91+-- TBD real parallel
92+{-# SPECIALIZE parallel :: AsyncT IO a -> AsyncT IO a -> StateT Context IO (Step a IO) #-}
93+parallel :: Monad m
94+ => AsyncT m a
95+ -> AsyncT m a
96+ -> StateT Context m (Step a m)
97+parallel ma mb = do
98+ step <- runAction ma
99+ case step of
100+ Stop -> runAsyncT mb
101+ Yield a mx -> return (Yield a (AsyncT (parallel mx mb)))
102+
79103instance MonadAsync m => Monad (AsyncT m) where
80104 {-# SPECIALIZE instance Monad (AsyncT IO) #-}
81− return a = AsyncT . return $ Just a
82− m >>= f = bind
83−
84− where
85−
86− {-# NOINLINE[1] bind #-}
87− bind = AsyncT $ do
88− modify $ \Context {continuations = fs, ..} ->
89− Context {continuations = (unsafeCoerce f) : fs, ..}
90− x <- runAsyncT m
91− modify $ \Context {continuations = (_ : fs), ..} ->
92− Context {continuations = fs, ..}
93− case x of
94− Just y -> runAsyncT $ f y
95− Nothing -> return Nothing
105+ return a = AsyncT . return $ Yield a stop
106+
107+ m >>= f = AsyncT $ do
108+ step <- runAction m
109+ case step of
110+ Stop -> return Stop -- XXX need to wait for the child threads
111+ Yield a ma -> runAsyncT $ (f a) <|> (ma >>= f)
96112
97113------------------------------------------------------------------------------
98114-- Functor
@@ -132,10 +148,8 @@ instance MonadAsync m => Applicative (AsyncT m) where
132148
133149instance MonadAsync m => Alternative (AsyncT m) where
134150 {-# SPECIALIZE instance Alternative (AsyncT IO) #-}
135− empty = AsyncT $ return Nothing
136− (<|>) m1 m2 = AsyncT $ do
137− r <- runAsyncTask False (runAsyncT m1)
138− maybe (runAsyncT m2) (return . Just) r
151+ empty = stop
152+ (<|>) m1 m2 = AsyncT $ parallel m1 m2
139153
140154instance MonadAsync m => MonadPlus (AsyncT m) where
141155 mzero = empty
@@ -162,7 +176,7 @@ instance (Num a, Monad (AsyncT m)) => Num (AsyncT m a) where
162176-------------------------------------------------------------------------------
163177
164178instance MonadTrans AsyncT where
165− lift mx = AsyncT $ lift mx >>= return . Just
179+ lift mx = AsyncT $ lift mx >>= return . (\a -> (Yield a stop))
166180
167181instance (MonadBase b m, MonadAsync m) => MonadBase b (AsyncT m) where
168182 liftBase = liftBaseDefault
@@ -171,6 +185,7 @@ instance (MonadBase b m, MonadAsync m) => MonadBase b (AsyncT m) where
171185-- monad-control
172186-------------------------------------------------------------------------------
173187
188+{-
174189instance MonadTransControl AsyncT where
175190 type StT AsyncT a = (Maybe a, Context)
176191 liftWith f = AsyncT $ StateT $ \s ->
@@ -186,6 +201,7 @@ instance (MonadBaseControl b m, MonadAsync m) => MonadBaseControl b (AsyncT m) w
186201 restoreM = defaultRestoreM
187202 {-# INLINABLE liftBaseWith #-}
188203 {-# INLINABLE restoreM #-}
204+-}
189205
190206------------------------------------------------------------------------------
191207-- Standard transformer instances
@@ -271,11 +287,13 @@ infixr 1 >>|
271287-- is not useful and should not be used. Even in an 'Alternative' composition
272288-- 'async' is not useful as the last action as the last action always runs in
273289-- the current thread.
290+{-
274291async :: MonadAsync m => AsyncT m a -> AsyncT m a
275292async action = AsyncT $ runAsyncTask True (runAsyncT action)
276293
277294makeAsync :: MonadAsync m => ((a -> m ()) -> m ()) -> AsyncT m a
278295makeAsync = AsyncT . makeCont
296+-}
279297
280298-- scatter
281299{-# SPECIALIZE each :: [a] -> AsyncT IO a #-}