git.iko.soy/streamly
on master help sign in
More refactor, reorg, remove additonalOperators class
a39705bHarendra Kumar
src/Duct/AsyncT.hs+81−109
compare with master
unifiedsplit
@@ -84,29 +84,6 @@ instance Monad (AsyncT m) => Functor (AsyncT m) where
84-- Applicative
84-- Applicative
85------------------------------------------------------------------------------
85------------------------------------------------------------------------------
86
86
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−
110instance Monad m => Applicative (AsyncT m) where
87instance Monad m => Applicative (AsyncT m) where
111 pure a = AsyncT . return $ Just a
88 pure a = AsyncT . return $ Just a
112 m1 <*> m2 = do { x1 <- m1; x2 <- m2; return (x1 x2) }
89 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
177 mappend x y = mappend <$> x <*> y
154 mappend x y = mappend <$> x <*> y
178 mempty = return mempty
155 mempty = return mempty
179
156
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−
230------------------------------------------------------------------------------
157------------------------------------------------------------------------------
231-- MonadIO
158-- MonadIO
232------------------------------------------------------------------------------
159------------------------------------------------------------------------------
@@ -284,8 +211,8 @@ waitForChildren chan pendingRef = do
284------------------------------------------------------------------------------
211------------------------------------------------------------------------------
285
212
286-- | Run a transient computation with a default initial state
213-- | Run a transient computation with a default initial state
287−runTransient :: forall m a. MonadIO m => AsyncT m a -> m (Maybe a, Context)
214+runContext :: forall m a. MonadIO m => AsyncT m a -> m (Maybe a, Context)
288−runTransient t = do
215+runContext t = do
289 childChan <- liftIO $ atomically newTChan
216 childChan <- liftIO $ atomically newTChan
290 pendingRef <- liftIO $ newIORef []
217 pendingRef <- liftIO $ newIORef []
291 credit <- liftIO $ newIORef maxBound
218 credit <- liftIO $ newIORef maxBound
@@ -304,7 +231,7 @@ runTransient t = do
304--waitAsync :: MonadIO m => AsyncT m a -> m [a]
231--waitAsync :: MonadIO m => AsyncT m a -> m [a]
305waitAsync :: MonadIO m => AsyncT m a -> m (Maybe a)
232waitAsync :: MonadIO m => AsyncT m a -> m (Maybe a)
306waitAsync m = do
233waitAsync m = do
307− (r, _) <- runTransient m
234+ (r, _) <- runContext m
308 return r
235 return r
309
236
310------------------------------------------------------------------------------
237------------------------------------------------------------------------------
@@ -386,6 +313,56 @@ sandbox mx = do
386 mx <*** modify (\s ->s { mfData = sd})
313 mx <*** modify (\s ->s { mfData = sd})
387 -}
314 -}
388
315
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+
389------------------------------------------------------------------------------
366------------------------------------------------------------------------------
390-- More operators, instances
367-- More operators, instances
391------------------------------------------------------------------------------
368------------------------------------------------------------------------------
@@ -399,33 +376,29 @@ instance (Num a, Monad (AsyncT m)) => Num (AsyncT m a) where
399 signum f = f >>= return . signum
376 signum f = f >>= return . signum
400
377
401{-
378{-
402−class AdditionalOperators m where
379+-- | Warning: Radically untyped stuff. handle with care
403−
380+getContinuations :: Monad m => StateM m [a -> AsyncT m b]
404− -- | Run @m a@ discarding its result before running @m b@.
381+getContinuations = do
405− (**>) :: m a -> m b -> m b
382+ EventF { fcomp = fs } <- get
406−
383+ return $ unsafeCoerce fs
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
417
384
418− atEnd :: m a -> m b -> m a
385+-- | Save a closure and a continuation ('x' and 'f' in 'x >>= f').
419− atEnd = (<***)
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+ , .. }
420
392
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), .. }
422
398
423− (**>) :: AsyncT m a -> AsyncT m b -> AsyncT m b
399+-}
424− (**>) x y =
425− AsyncT $ do
426− runAsyncT x
427− runAsyncT y
428
400
401+{-
429 (<***) :: AsyncT m a -> AsyncT m b -> AsyncT m a
402 (<***) :: AsyncT m a -> AsyncT m b -> AsyncT m a
430 (<***) ma mb =
403 (<***) ma mb =
431 AsyncT $ do
404 AsyncT $ do
@@ -436,14 +409,6 @@ instance (Monad m, Monad (AsyncT m)) => AdditionalOperators (AsyncT m) where
436 restoreStack fs
409 restoreStack fs
437 return a
410 return a
438
411
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−
447infixr 1 <***, <**, **>
412infixr 1 <***, <**, **>
448
413
449-- | Run @b@ once, discarding its result when the first task in task set @a@
414-- | Run @b@ once, discarding its result when the first task in task set @a@
@@ -467,10 +432,17 @@ infixr 1 <***, <**, **>
467
432
468-}
433-}
469
434
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.
470(<**) :: Monad m => AsyncT m a -> AsyncT m b -> AsyncT m a
444(<**) :: Monad m => AsyncT m a -> AsyncT m b -> AsyncT m a
471(<**) ma mb = AsyncT $ do
445(<**) ma mb = AsyncT $ do
472 a <- runAsyncT ma
446 a <- runAsyncT ma
473 runAsyncT mb
447 runAsyncT mb
474 return a
448 return a
475−
476−infixr 1 <**