git.iko.soy/streamly
on 02a745f help sign in
streamly/src/Asyncly/Backtrack.hs
95 lines 3.6 kB history raw
1{-# LANGUAGE ExistentialQuantification #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE InstanceSigs #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE Rank2Types #-}
7{-# LANGUAGE RecordWildCards #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE UndecidableInstances #-}
12module Strands.AsyncT
13 (
14 )
15where
17import Control.Applicative (Alternative (..))
18import Control.Monad.Base (MonadBase (..), liftBaseDefault)
19import Control.Monad.Catch (MonadThrow, throwM)
20import Control.Monad.State (MonadIO (..), MonadPlus (..),
21 MonadState (..), StateT (..),
22 liftM, modify, runStateT, when)
23import Control.Monad.Trans.Class (MonadTrans (lift))
24import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
25 MonadTransControl (..),
26 defaultLiftBaseWith,
27 defaultRestoreM)
28import Data.Dynamic (Typeable)
30import Strands.Context
32--import Debug.Trace (traceM)
34------------------------------------------------------------------------------
35-- Utilities
36------------------------------------------------------------------------------
38-- | If the first parameter is 'Nothing' return the second parameter otherwise
39-- return the first parameter..
40onNothing :: Monad m => m (Maybe b) -> m b -> m b
41onNothing iox iox'= do
42 mx <- iox
43 case mx of
44 Just x -> return x
45 Nothing -> iox'
47------------------------------------------------------------------------------
48-- Backtracking
49------------------------------------------------------------------------------
51{-
52-- | Run the closure (the 'x' in 'x >>= f') of the current bind operation.
53runClosure :: EventF -> StateM m (Maybe a)
54runClosure EventF { xcomp = x } = runAsyncT (unsafeCoerce x)
56-- | Run the continuation (the 'f' in 'x >>= f') of the current bind operation with the current state.
57runContinuation :: MonadIO m => EventF -> a -> StateM m (Maybe b)
58runContinuation EventF { fcomp = fs } =
59 runAsyncT . (compose $ (unsafeCoerce fs))
61data Backtrack b = Show b => Backtrack
62 { backtracking :: Maybe b
63 , backStack :: [EventF]
64 } deriving Typeable
66backStateOf :: (Monad m, Show a) => a -> m (Backtrack a)
67backStateOf reason = return $ Backtrack (Nothing `asTypeOf` (Just reason)) []
69-- | Start the undo process for the given undo track id. Performs all the undo
70-- actions registered till now in reverse order. An undo action can use
71-- 'forward' to stop the undo process and resume forward execution. If there
72-- are no more undo actions registered execution stops and a 'stop' action is
73-- returned.
74--
75back :: (MonadIO m, Typeable b, Show b) => b -> AsyncT m a
76back reason = AsyncT $ do
77 bs <- getData `onNothing` backStateOf reason
78 goBackt bs
80 where
82 goBackt (Backtrack _ [] )= return Nothing
83 goBackt (Backtrack _ (stack@(first : bs)) )= do
84 (setData $ Backtrack (Just reason) stack)
86 mr <- runClosure first
88 Backtrack b _ <- getData `onNothing` backStateOf reason
89 case mr of
90 Nothing -> return empty
91 Just x -> case b of
92 Nothing -> runContinuation first x
93 justreason -> goBackt $ Backtrack justreason bs
95-}