@@ -12,7 +12,7 @@
1212module Strands.AsyncT
1313 ( AsyncT (..)
1414 , (<**)
15− , onNothing
15+ , (**>)
1616 , dbg
1717 )
1818where
@@ -21,14 +21,12 @@ import Control.Applicative (Alternative (..))
2121import Control.Monad.Base (MonadBase (..), liftBaseDefault)
2222import Control.Monad.Catch (MonadThrow, throwM)
2323import Control.Monad.State (MonadIO (..), MonadPlus (..),
24− MonadState (..), StateT (..),
25− liftM, modify, runStateT, when)
24+ StateT (..), liftM, runStateT)
2625import Control.Monad.Trans.Class (MonadTrans (lift))
2726import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
2827 MonadTransControl (..),
2928 defaultLiftBaseWith,
3029 defaultRestoreM)
31−import Data.Dynamic (Typeable)
3230
3331import Strands.Context
3432
@@ -46,15 +44,6 @@ newtype AsyncT m a = AsyncT { runAsyncT :: StateT Context m (Maybe a) }
4644dbg :: Monad m => a -> m ()
4745dbg _ = return ()
4846
49−-- | If the first parameter is 'Nothing' return the second parameter otherwise
50−-- return the first parameter..
51−onNothing :: Monad m => m (Maybe b) -> m b -> m b
52−onNothing iox iox'= do
53− mx <- iox
54− case mx of
55− Just x -> return x
56− Nothing -> iox'
57−
5847------------------------------------------------------------------------------
5948-- Functor
6049------------------------------------------------------------------------------
@@ -143,135 +132,6 @@ instance (MonadBaseControl b m, MonadIO m) => MonadBaseControl b (AsyncT m) wher
143132instance MonadThrow m => MonadThrow (AsyncT m) where
144133 throwM e = lift $ throwM e
145134
146−------------------------------------------------------------------------------
147−-- * Extensible State: Session Data Management
148−------------------------------------------------------------------------------
149−
150−-- | Retrieve a previously stored data item of the given data type from the
151−-- monad state. The data type to retrieve is implicitly determined from the
152−-- requested type context.
153−-- If the data item is not found, an 'empty' value (a void event) is returned.
154−-- Remember that an empty value stops the monad computation. If you want to
155−-- print an error message or a default value in that case, you can use an
156−-- 'Alternative' composition. For example:
157−--
158−-- > getSData <|> error "no data"
159−-- > getInt = getSData <|> return (0 :: Int)
160−getSData :: (Monad m, Typeable a) => AsyncT m a
161−getSData = AsyncT getData
162−
163−-- | 'setSData' stores a data item in the monad state which can be retrieved
164−-- later using 'getData' or 'getSData'. Stored data items are keyed by their
165−-- data type, and therefore the data type must be 'Typeable' and only one item
166−-- of a given type can be stored. A newtype wrapper can be used to distinguish
167−-- two data items of the same type when required.
168−--
169−-- @
170−-- import Control.Monad.IO.Class (liftIO)
171−-- import Transient.Base
172−-- import Data.Typeable
173−--
174−-- data Person = Person
175−-- { name :: String
176−-- , age :: Int
177−-- } deriving Typeable
178−--
179−-- main = keep $ do
180−-- setSData $ Person "Alberto" 55
181−-- Person name age <- getSData
182−-- liftIO $ print (name, age)
183−-- @
184−setSData :: (Monad m, Typeable a) => a -> AsyncT m ()
185−setSData x = AsyncT $ setData x >> return (Just ())
186−
187−-- | Accepts a function that takes the current value of the stored data type
188−-- and returns the modified value. If the function returns 'Nothing' the value
189−-- is deleted otherwise updated.
190−modifySData :: (Monad m, Typeable a) => (Maybe a -> Maybe a) -> AsyncT m ()
191−modifySData x = AsyncT $ modifyData x >> return (Just ())
192−
193−-- | Delete the data item of the given type from the monad state.
194−delSData :: (Monad m, Typeable a) => a -> AsyncT m ()
195−delSData x = AsyncT $ delData x >> return (Just ())
196−
197−------------------------------------------------------------------------------
198−-- MonadState for AsyncT m
199−------------------------------------------------------------------------------
200−
201−instance (Monad m, Monad (AsyncT m)) => MonadState Context (AsyncT m) where
202− get = AsyncT $ get >>= return . Just
203− put x = AsyncT $ put x >> return (Just ())
204− state f = AsyncT $ do
205− s <- get
206− let ~(a, s') = f s
207− put s'
208− return $ Just a
209−
210−{-
211−-- | Run an action, if the result is a void action undo any state changes
212−-- that it might have caused.
213−try :: MonadIO m => AsyncT m a -> AsyncT m a
214−try mx = do
215− sd <- gets mfData
216− mx <|> (modify (\s -> s { mfData = sd }) >> empty)
217−
218−-- | Executes the computation and reset the state either if it fails or not
219−sandbox :: MonadIO m => AsyncT m a -> AsyncT m a
220−sandbox mx = do
221− sd <- gets mfData
222− mx <*** modify (\s ->s { mfData = sd})
223− -}
224−
225−------------------------------------------------------------------------------
226−-- Backtracking
227−------------------------------------------------------------------------------
228−
229−{-
230−-- | Run the closure (the 'x' in 'x >>= f') of the current bind operation.
231−runClosure :: EventF -> StateM m (Maybe a)
232−runClosure EventF { xcomp = x } = runAsyncT (unsafeCoerce x)
233−
234−-- | Run the continuation (the 'f' in 'x >>= f') of the current bind operation with the current state.
235−runContinuation :: MonadIO m => EventF -> a -> StateM m (Maybe b)
236−runContinuation EventF { fcomp = fs } =
237− runAsyncT . (compose $ (unsafeCoerce fs))
238−
239−data Backtrack b = Show b => Backtrack
240− { backtracking :: Maybe b
241− , backStack :: [EventF]
242− } deriving Typeable
243−
244−backStateOf :: (Monad m, Show a) => a -> m (Backtrack a)
245−backStateOf reason = return $ Backtrack (Nothing `asTypeOf` (Just reason)) []
246−
247−-- | Start the undo process for the given undo track id. Performs all the undo
248−-- actions registered till now in reverse order. An undo action can use
249−-- 'forward' to stop the undo process and resume forward execution. If there
250−-- are no more undo actions registered execution stops and a 'stop' action is
251−-- returned.
252−--
253−back :: (MonadIO m, Typeable b, Show b) => b -> AsyncT m a
254−back reason = AsyncT $ do
255− bs <- getData `onNothing` backStateOf reason
256− goBackt bs
257−
258− where
259−
260− goBackt (Backtrack _ [] )= return Nothing
261− goBackt (Backtrack _ (stack@(first : bs)) )= do
262− (setData $ Backtrack (Just reason) stack)
263−
264− mr <- runClosure first
265−
266− Backtrack b _ <- getData `onNothing` backStateOf reason
267− case mr of
268− Nothing -> return empty
269− Just x -> case b of
270− Nothing -> runContinuation first x
271− justreason -> goBackt $ Backtrack justreason bs
272−
273−-}
274−
275135------------------------------------------------------------------------------
276136-- More operators, instances
277137------------------------------------------------------------------------------
@@ -346,12 +206,12 @@ infixr 1 <**, **>
346206-- | Run @m a@ discarding its result before running @m b@.
347207(**>) :: Monad m => AsyncT m a -> AsyncT m b -> AsyncT m b
348208(**>) x y = AsyncT $ do
349− runAsyncT x
209+ _ <- runAsyncT x
350210 runAsyncT y
351211
352212-- | Run @m b@ discarding its result, after the whole task set @m a@ is done.
353213(<**) :: Monad m => AsyncT m a -> AsyncT m b -> AsyncT m a
354214(<**) ma mb = AsyncT $ do
355215 a <- runAsyncT ma
356− runAsyncT mb
216+ _ <- runAsyncT mb
357217 return a