@@ -84,29 +84,6 @@ instance Monad (AsyncT m) => Functor (AsyncT m) where
8484-- Applicative
8585------------------------------------------------------------------------------
8686
87−{-
88−-- | Warning: Radically untyped stuff. handle with care
89−getContinuations :: Monad m => StateM m [a -> AsyncT m b]
90−getContinuations = do
91− EventF { fcomp = fs } <- get
92− return $ unsafeCoerce fs
93−
94−-- | Save a closure and a continuation ('x' and 'f' in 'x >>= f').
95−setContinuation :: Monad m
96− => AsyncT m a -> (a -> AsyncT m b) -> [c -> AsyncT m c] -> StateM m ()
97−setContinuation b c fs = do
98− modify $ \EventF{..} -> EventF { xcomp = b
99− , fcomp = unsafeCoerce c : fs
100− , .. }
101−
102−-- | Restore the continuations to the provided ones.
103−-- | NOTE: Events are also cleared out.
104−restoreStack :: MonadState EventF m => t -> m ()
105−restoreStack fs = modify $ \EventF {..} ->
106− EventF { event = Nothing, fcomp = (unsafeCoerce fs), .. }
107−
108−-}
109−
11087instance Monad m => Applicative (AsyncT m) where
11188 pure a = AsyncT . return $ Just a
11289 m1 <*> m2 = do { x1 <- m1; x2 <- m2; return (x1 x2) }
@@ -177,56 +154,6 @@ instance (Monoid a, Monad (AsyncT m)) => Monoid (AsyncT m a) where
177154 mappend x y = mappend <$> x <*> y
178155 mempty = return mempty
179156
180−------------------------------------------------------------------------------
181−-- Backtracking
182−------------------------------------------------------------------------------
183−
184−{-
185−-- | Run the closure (the 'x' in 'x >>= f') of the current bind operation.
186−runClosure :: EventF -> StateM m (Maybe a)
187−runClosure EventF { xcomp = x } = runAsyncT (unsafeCoerce x)
188−
189−-- | Run the continuation (the 'f' in 'x >>= f') of the current bind operation with the current state.
190−runContinuation :: MonadIO m => EventF -> a -> StateM m (Maybe b)
191−runContinuation EventF { fcomp = fs } =
192− runAsyncT . (compose $ (unsafeCoerce fs))
193−
194−data Backtrack b = Show b => Backtrack
195− { backtracking :: Maybe b
196− , backStack :: [EventF]
197− } deriving Typeable
198−
199−backStateOf :: (Monad m, Show a) => a -> m (Backtrack a)
200−backStateOf reason = return $ Backtrack (Nothing `asTypeOf` (Just reason)) []
201−
202−-- | Start the undo process for the given undo track id. Performs all the undo
203−-- actions registered till now in reverse order. An undo action can use
204−-- 'forward' to stop the undo process and resume forward execution. If there
205−-- are no more undo actions registered execution stops and a 'stop' action is
206−-- returned.
207−--
208−back :: (MonadIO m, Typeable b, Show b) => b -> AsyncT m a
209−back reason = AsyncT $ do
210− bs <- getData `onNothing` backStateOf reason
211− goBackt bs
212−
213− where
214−
215− goBackt (Backtrack _ [] )= return Nothing
216− goBackt (Backtrack _ (stack@(first : bs)) )= do
217− (setData $ Backtrack (Just reason) stack)
218−
219− mr <- runClosure first
220−
221− Backtrack b _ <- getData `onNothing` backStateOf reason
222− case mr of
223− Nothing -> return empty
224− Just x -> case b of
225− Nothing -> runContinuation first x
226− justreason -> goBackt $ Backtrack justreason bs
227−
228−-}
229−
230157------------------------------------------------------------------------------
231158-- MonadIO
232159------------------------------------------------------------------------------
@@ -284,8 +211,8 @@ waitForChildren chan pendingRef = do
284211------------------------------------------------------------------------------
285212
286213-- | Run a transient computation with a default initial state
287−runTransient :: forall m a. MonadIO m => AsyncT m a -> m (Maybe a, Context)
288−runTransient t = do
214+runContext :: forall m a. MonadIO m => AsyncT m a -> m (Maybe a, Context)
215+runContext t = do
289216 childChan <- liftIO $ atomically newTChan
290217 pendingRef <- liftIO $ newIORef []
291218 credit <- liftIO $ newIORef maxBound
@@ -304,7 +231,7 @@ runTransient t = do
304231--waitAsync :: MonadIO m => AsyncT m a -> m [a]
305232waitAsync :: MonadIO m => AsyncT m a -> m (Maybe a)
306233waitAsync m = do
307− (r, _) <- runTransient m
234+ (r, _) <- runContext m
308235 return r
309236
310237------------------------------------------------------------------------------
@@ -386,6 +313,56 @@ sandbox mx = do
386313 mx <*** modify (\s ->s { mfData = sd})
387314 -}
388315
316+------------------------------------------------------------------------------
317+-- Backtracking
318+------------------------------------------------------------------------------
319+
320+{-
321+-- | Run the closure (the 'x' in 'x >>= f') of the current bind operation.
322+runClosure :: EventF -> StateM m (Maybe a)
323+runClosure EventF { xcomp = x } = runAsyncT (unsafeCoerce x)
324+
325+-- | Run the continuation (the 'f' in 'x >>= f') of the current bind operation with the current state.
326+runContinuation :: MonadIO m => EventF -> a -> StateM m (Maybe b)
327+runContinuation EventF { fcomp = fs } =
328+ runAsyncT . (compose $ (unsafeCoerce fs))
329+
330+data Backtrack b = Show b => Backtrack
331+ { backtracking :: Maybe b
332+ , backStack :: [EventF]
333+ } deriving Typeable
334+
335+backStateOf :: (Monad m, Show a) => a -> m (Backtrack a)
336+backStateOf reason = return $ Backtrack (Nothing `asTypeOf` (Just reason)) []
337+
338+-- | Start the undo process for the given undo track id. Performs all the undo
339+-- actions registered till now in reverse order. An undo action can use
340+-- 'forward' to stop the undo process and resume forward execution. If there
341+-- are no more undo actions registered execution stops and a 'stop' action is
342+-- returned.
343+--
344+back :: (MonadIO m, Typeable b, Show b) => b -> AsyncT m a
345+back reason = AsyncT $ do
346+ bs <- getData `onNothing` backStateOf reason
347+ goBackt bs
348+
349+ where
350+
351+ goBackt (Backtrack _ [] )= return Nothing
352+ goBackt (Backtrack _ (stack@(first : bs)) )= do
353+ (setData $ Backtrack (Just reason) stack)
354+
355+ mr <- runClosure first
356+
357+ Backtrack b _ <- getData `onNothing` backStateOf reason
358+ case mr of
359+ Nothing -> return empty
360+ Just x -> case b of
361+ Nothing -> runContinuation first x
362+ justreason -> goBackt $ Backtrack justreason bs
363+
364+-}
365+
389366------------------------------------------------------------------------------
390367-- More operators, instances
391368------------------------------------------------------------------------------
@@ -399,33 +376,29 @@ instance (Num a, Monad (AsyncT m)) => Num (AsyncT m a) where
399376 signum f = f >>= return . signum
400377
401378{-
402−class AdditionalOperators m where
403−
404− -- | Run @m a@ discarding its result before running @m b@.
405− (**>) :: m a -> m b -> m b
406−
407− -- | Run @m b@ discarding its result, after the whole task set @m a@ is
408− -- done.
409− (<**) :: m a -> m b -> m a
410−
411− atEnd' :: m a -> m b -> m a
412− atEnd' = (<**)
413−
414− -- | Run @m b@ discarding its result, once after each task in @m a@, and
415− -- once again after the whole task set is done.
416− (<***) :: m a -> m b -> m a
379+-- | Warning: Radically untyped stuff. handle with care
380+getContinuations :: Monad m => StateM m [a -> AsyncT m b]
381+getContinuations = do
382+ EventF { fcomp = fs } <- get
383+ return $ unsafeCoerce fs
417384
418− atEnd :: m a -> m b -> m a
419− atEnd = (<***)
385+-- | Save a closure and a continuation ('x' and 'f' in 'x >>= f').
386+setContinuation :: Monad m
387+ => AsyncT m a -> (a -> AsyncT m b) -> [c -> AsyncT m c] -> StateM m ()
388+setContinuation b c fs = do
389+ modify $ \EventF{..} -> EventF { xcomp = b
390+ , fcomp = unsafeCoerce c : fs
391+ , .. }
420392
421−instance (Monad m, Monad (AsyncT m)) => AdditionalOperators (AsyncT m) where
393+-- | Restore the continuations to the provided ones.
394+-- | NOTE: Events are also cleared out.
395+restoreStack :: MonadState EventF m => t -> m ()
396+restoreStack fs = modify $ \EventF {..} ->
397+ EventF { event = Nothing, fcomp = (unsafeCoerce fs), .. }
422398
423− (**>) :: AsyncT m a -> AsyncT m b -> AsyncT m b
424− (**>) x y =
425− AsyncT $ do
426− runAsyncT x
427− runAsyncT y
399+-}
428400
401+{-
429402 (<***) :: AsyncT m a -> AsyncT m b -> AsyncT m a
430403 (<***) ma mb =
431404 AsyncT $ do
@@ -436,14 +409,6 @@ instance (Monad m, Monad (AsyncT m)) => AdditionalOperators (AsyncT m) where
436409 restoreStack fs
437410 return a
438411
439− (<**) :: AsyncT m a -> AsyncT m b -> AsyncT m a
440− (<**) ma mb =
441− AsyncT $ do
442− a <- runAsyncT ma
443−
444− runAsyncT mb
445− return a
446−
447412infixr 1 <***, <**, **>
448413
449414-- | Run @b@ once, discarding its result when the first task in task set @a@
@@ -467,10 +432,17 @@ infixr 1 <***, <**, **>
467432
468433-}
469434
435+infixr 1 <**, **>
436+
437+-- | Run @m a@ discarding its result before running @m b@.
438+(**>) :: Monad m => AsyncT m a -> AsyncT m b -> AsyncT m b
439+(**>) x y = AsyncT $ do
440+ runAsyncT x
441+ runAsyncT y
442+
443+-- | Run @m b@ discarding its result, after the whole task set @m a@ is done.
470444(<**) :: Monad m => AsyncT m a -> AsyncT m b -> AsyncT m a
471445(<**) ma mb = AsyncT $ do
472446 a <- runAsyncT ma
473447 runAsyncT mb
474448 return a
475−
476−infixr 1 <**