@@ -109,75 +109,15 @@ restoreStack :: MonadState EventF m => t -> m ()
109restoreStack fs = modify $ \EventF {..} ->
109restoreStack fs = modify $ \EventF {..} ->
110 EventF { event = Nothing, fcomp = (unsafeCoerce fs), .. }
110 EventF { event = Nothing, fcomp = (unsafeCoerce fs), .. }
112−instance MonadIO m => Applicative (AsyncT m) where
112+instance Monad m => Applicative (AsyncT m) where
113 pure a = AsyncT . return $ Just a
113 pure a = AsyncT . return $ Just a
114−
114+ m1 <*> m2 = do { x1 <- m1; x2 <- m2; return (x1 x2) }
115− f <*> g = AsyncT $ do
116− rf <- liftIO $ newIORef (Nothing,[])
117− rg <- liftIO $ newIORef (Nothing,[])
118− fs <- getContinuations
120− let hasWait (_:Wait:_) = True
123− appf k = AsyncT $ do
124− Log rec _ full <- getData `onNothing` return (Log False [] [])
125− (liftIO $ writeIORef rf (Just k,full))
126− (x, full2)<- liftIO $ readIORef rg
127− when (hasWait full ) $
128− let full'= head full: full2
129− in (setData $ Log rec full' full')
130− return $ Just (unsafeCoerce k) <*> x
132− appg x = AsyncT $ do
133− Log rec _ full <- getData `onNothing` return (Log False [] [])
134− liftIO $ writeIORef rg (Just x, full)
135− (k,full1) <- liftIO $ readIORef rf
136− when (hasWait full) $
137− let full'= head full: full1
138− in (setData $ Log rec full' full')
139− return $ unsafeCoerce k <*> Just x
141− setContinuation f appf fs
144− was <- getData `onNothing` return NoRemote
145− when (was == WasParallel) $ setData NoRemote
147− Log recovery _ full <- getData `onNothing` return (Log False [] [])
151− if was== WasRemote || (not recovery && was == NoRemote && isNothing k )
152− -- if the first operand was a remote request
153− -- (so this node is not master and hasn't to execute the whole expression)
154− -- or it was not an asyncronous term (a normal term without async or parallel
155− -- like primitives) and is nothing
160− when (isJust k) $ liftIO $ writeIORef rf (k,full)
161− -- when necessary since it maybe WasParallel and Nothing
163− setContinuation g appg fs
166− Log _ _ full' <- getData `onNothing` return (Log False [] [])
167− liftIO $ writeIORef rg (x,full')
169− k'' <- if was== WasParallel
171− (k',_) <- liftIO $ readIORef rf -- since k may have been updated by a parallel f
176------------------------------------------------------------------------------
116------------------------------------------------------------------------------
177-- Alternative
117-- Alternative
178------------------------------------------------------------------------------
118------------------------------------------------------------------------------
180−instance MonadIO m => Alternative (AsyncT m) where
120+instance Monad m => Alternative (AsyncT m) where
181 empty = AsyncT $ return Nothing
121 empty = AsyncT $ return Nothing
182 (<|>) x y = AsyncT $ do
122 (<|>) x y = AsyncT $ do
183 mx <- runAsyncT x
123 mx <- runAsyncT x
@@ -203,41 +143,30 @@ tailsafe :: [a] -> [a]
203tailsafe [] = []
143tailsafe [] = []
204tailsafe (_:xs) = xs
144tailsafe (_:xs) = xs
206−-- | Set the current closure and continuation for the current statement
207−setEventCont :: Monad m => AsyncT m a -> (a -> AsyncT m b) -> StateM m EventF
208−setEventCont x f = do
209− EventF { fcomp = fs, .. } <- get
210− let cont = EventF { xcomp = x
211− , fcomp = unsafeCoerce f : unsafeCoerce fs
216−-- | Reset the closure and continuation. Remove inner binds that the previous
217−-- computations may have stacked in the list of continuations.
218−resetEventCont :: forall m a b. MonadIO m
219− => Maybe a -> EventF -> StateM m (AsyncT m b -> AsyncT m b)
220−resetEventCont mx _ = do
221− EventF { fcomp = fs, .. } <- get
222− let f my = case my of
223− Nothing -> (empty :: AsyncT m a)
224− Just x -> unsafeCoerce (head fs) x
225− put $ EventF { xcomp = f mx
226− , fcomp = tailsafe (unsafeCoerce fs)
230−instance MonadIO m => Monad (AsyncT m) where
146+instance Monad m => Monad (AsyncT m) where
231 return = pure
147 return = pure
232− x >>= f = AsyncT $ do
148+ m >>= f = AsyncT $ do
149+ -- save m in xcomp and add f to the head of fcomp
233− c <- setEventCont x f
150+ -- _ <- setEventCont m f
151+ modify $ \EventF { fcomp = fs, .. } ->
152+ EventF { xcomp = unsafeCoerce m, fcomp = unsafeCoerce f : fs, .. }
154+ -- run m under this modified environment
234− mk <- runAsyncT x
155+ mres <- runAsyncT m
235− _ <- resetEventCont mk c
156+ -- remove the head of fcomp apply it to mres and that becomes the new xcomp.
157+ -- is head of fcomp always the same as f?
236− case mk of
158+ let res = case mres of
237− Just k -> runAsyncT (f k)
159+ Nothing -> empty
238− Nothing -> return Nothing
160+ Just x -> f x
162+ -- XXX why would we have more than one continuation? Can we have just one
163+ -- instead of a list and remove it after every bind?
164+ modify $ \EventF { fcomp = fs, .. } ->
165+ EventF { xcomp = unsafeCoerce res, fcomp = tailsafe fs, .. }
240−instance MonadIO m => MonadPlus (AsyncT m) where
169+instance Monad m => MonadPlus (AsyncT m) where
241 mzero = empty
170 mzero = empty
242 mplus = (<|>)
171 mplus = (<|>)