git.iko.soy/streamly
on master help sign in
Reorganize modules
ef68640Harendra Kumar
src/Strands/AsyncT.hs+4−144
compare with master
unifiedsplit
@@ -12,7 +12,7 @@
12module Strands.AsyncT
12module Strands.AsyncT
13 ( AsyncT (..)
13 ( AsyncT (..)
14 , (<**)
14 , (<**)
15− , onNothing
15+ , (**>)
16 , dbg
16 , dbg
17 )
17 )
18where
18where
@@ -21,14 +21,12 @@ import Control.Applicative (Alternative (..))
21import Control.Monad.Base (MonadBase (..), liftBaseDefault)
21import Control.Monad.Base (MonadBase (..), liftBaseDefault)
22import Control.Monad.Catch (MonadThrow, throwM)
22import Control.Monad.Catch (MonadThrow, throwM)
23import Control.Monad.State (MonadIO (..), MonadPlus (..),
23import Control.Monad.State (MonadIO (..), MonadPlus (..),
24− MonadState (..), StateT (..),
25− liftM, modify, runStateT, when)
24+ StateT (..), liftM, runStateT)
26import Control.Monad.Trans.Class (MonadTrans (lift))
25import Control.Monad.Trans.Class (MonadTrans (lift))
27import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
26import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
28 MonadTransControl (..),
27 MonadTransControl (..),
29 defaultLiftBaseWith,
28 defaultLiftBaseWith,
30 defaultRestoreM)
29 defaultRestoreM)
31−import Data.Dynamic (Typeable)
32
30
33import Strands.Context
31import Strands.Context
34
32
@@ -46,15 +44,6 @@ newtype AsyncT m a = AsyncT { runAsyncT :: StateT Context m (Maybe a) }
46dbg :: Monad m => a -> m ()
44dbg :: Monad m => a -> m ()
47dbg _ = return ()
45dbg _ = return ()
48
46
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−
58------------------------------------------------------------------------------
47------------------------------------------------------------------------------
59-- Functor
48-- Functor
60------------------------------------------------------------------------------
49------------------------------------------------------------------------------
@@ -143,135 +132,6 @@ instance (MonadBaseControl b m, MonadIO m) => MonadBaseControl b (AsyncT m) wher
143instance MonadThrow m => MonadThrow (AsyncT m) where
132instance MonadThrow m => MonadThrow (AsyncT m) where
144 throwM e = lift $ throwM e
133 throwM e = lift $ throwM e
145
134
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−
275------------------------------------------------------------------------------
135------------------------------------------------------------------------------
276-- More operators, instances
136-- More operators, instances
277------------------------------------------------------------------------------
137------------------------------------------------------------------------------
@@ -346,12 +206,12 @@ infixr 1 <**, **>
346-- | Run @m a@ discarding its result before running @m b@.
206-- | Run @m a@ discarding its result before running @m b@.
347(**>) :: Monad m => AsyncT m a -> AsyncT m b -> AsyncT m b
207(**>) :: Monad m => AsyncT m a -> AsyncT m b -> AsyncT m b
348(**>) x y = AsyncT $ do
208(**>) x y = AsyncT $ do
349− runAsyncT x
209+ _ <- runAsyncT x
350 runAsyncT y
210 runAsyncT y
351
211
352-- | Run @m b@ discarding its result, after the whole task set @m a@ is done.
212-- | Run @m b@ discarding its result, after the whole task set @m a@ is done.
353(<**) :: Monad m => AsyncT m a -> AsyncT m b -> AsyncT m a
213(<**) :: Monad m => AsyncT m a -> AsyncT m b -> AsyncT m a
354(<**) ma mb = AsyncT $ do
214(<**) ma mb = AsyncT $ do
355 a <- runAsyncT ma
215 a <- runAsyncT ma
356− runAsyncT mb
216+ _ <- runAsyncT mb
357 return a
217 return a
src/Strands/Backtrack.hsnew file+95
@@ -0,0 +1,95 @@
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 #-}
11+
12+module Strands.AsyncT
13+ (
14+ )
15+where
16+
17+import Control.Applicative (Alternative (..))
18+import Control.Monad.Base (MonadBase (..), liftBaseDefault)
19+import Control.Monad.Catch (MonadThrow, throwM)
20+import Control.Monad.State (MonadIO (..), MonadPlus (..),
21+ MonadState (..), StateT (..),
22+ liftM, modify, runStateT, when)
23+import Control.Monad.Trans.Class (MonadTrans (lift))
24+import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
25+ MonadTransControl (..),
26+ defaultLiftBaseWith,
27+ defaultRestoreM)
28+import Data.Dynamic (Typeable)
29+
30+import Strands.Context
31+
32+--import Debug.Trace (traceM)
33+
34+------------------------------------------------------------------------------
35+-- Utilities
36+------------------------------------------------------------------------------
37+
38+-- | If the first parameter is 'Nothing' return the second parameter otherwise
39+-- return the first parameter..
40+onNothing :: Monad m => m (Maybe b) -> m b -> m b
41+onNothing iox iox'= do
42+ mx <- iox
43+ case mx of
44+ Just x -> return x
45+ Nothing -> iox'
46+
47+------------------------------------------------------------------------------
48+-- Backtracking
49+------------------------------------------------------------------------------
50+
51+{-
52+-- | Run the closure (the 'x' in 'x >>= f') of the current bind operation.
53+runClosure :: EventF -> StateM m (Maybe a)
54+runClosure EventF { xcomp = x } = runAsyncT (unsafeCoerce x)
55+
56+-- | Run the continuation (the 'f' in 'x >>= f') of the current bind operation with the current state.
57+runContinuation :: MonadIO m => EventF -> a -> StateM m (Maybe b)
58+runContinuation EventF { fcomp = fs } =
59+ runAsyncT . (compose $ (unsafeCoerce fs))
60+
61+data Backtrack b = Show b => Backtrack
62+ { backtracking :: Maybe b
63+ , backStack :: [EventF]
64+ } deriving Typeable
65+
66+backStateOf :: (Monad m, Show a) => a -> m (Backtrack a)
67+backStateOf reason = return $ Backtrack (Nothing `asTypeOf` (Just reason)) []
68+
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+--
75+back :: (MonadIO m, Typeable b, Show b) => b -> AsyncT m a
76+back reason = AsyncT $ do
77+ bs <- getData `onNothing` backStateOf reason
78+ goBackt bs
79+
80+ where
81+
82+ goBackt (Backtrack _ [] )= return Nothing
83+ goBackt (Backtrack _ (stack@(first : bs)) )= do
84+ (setData $ Backtrack (Just reason) stack)
85+
86+ mr <- runClosure first
87+
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
94+
95+-}
src/Strands/State.hsnew file+109
@@ -0,0 +1,109 @@
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 #-}
11+
12+module Strands.State
13+ (
14+ )
15+where
16+
17+import Control.Applicative (Alternative (..))
18+import Control.Monad.Base (MonadBase (..), liftBaseDefault)
19+import Control.Monad.Catch (MonadThrow, throwM)
20+import Control.Monad.State (MonadIO (..), MonadPlus (..),
21+ MonadState (..), StateT (..),
22+ liftM, modify, runStateT, when)
23+import Control.Monad.Trans.Class (MonadTrans (lift))
24+import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
25+ MonadTransControl (..),
26+ defaultLiftBaseWith,
27+ defaultRestoreM)
28+import Data.Dynamic (Typeable)
29+
30+import Strands.Context
31+
32+------------------------------------------------------------------------------
33+-- * Extensible State: Session Data Management
34+------------------------------------------------------------------------------
35+
36+-- | Retrieve a previously stored data item of the given data type from the
37+-- monad state. The data type to retrieve is implicitly determined from the
38+-- requested type context.
39+-- If the data item is not found, an 'empty' value (a void event) is returned.
40+-- Remember that an empty value stops the monad computation. If you want to
41+-- print an error message or a default value in that case, you can use an
42+-- 'Alternative' composition. For example:
43+--
44+-- > getSData <|> error "no data"
45+-- > getInt = getSData <|> return (0 :: Int)
46+getSData :: (Monad m, Typeable a) => AsyncT m a
47+getSData = AsyncT getData
48+
49+-- | 'setSData' stores a data item in the monad state which can be retrieved
50+-- later using 'getData' or 'getSData'. Stored data items are keyed by their
51+-- data type, and therefore the data type must be 'Typeable' and only one item
52+-- of a given type can be stored. A newtype wrapper can be used to distinguish
53+-- two data items of the same type when required.
54+--
55+-- @
56+-- import Control.Monad.IO.Class (liftIO)
57+-- import Transient.Base
58+-- import Data.Typeable
59+--
60+-- data Person = Person
61+-- { name :: String
62+-- , age :: Int
63+-- } deriving Typeable
64+--
65+-- main = keep $ do
66+-- setSData $ Person "Alberto" 55
67+-- Person name age <- getSData
68+-- liftIO $ print (name, age)
69+-- @
70+setSData :: (Monad m, Typeable a) => a -> AsyncT m ()
71+setSData x = AsyncT $ setData x >> return (Just ())
72+
73+-- | Accepts a function that takes the current value of the stored data type
74+-- and returns the modified value. If the function returns 'Nothing' the value
75+-- is deleted otherwise updated.
76+modifySData :: (Monad m, Typeable a) => (Maybe a -> Maybe a) -> AsyncT m ()
77+modifySData x = AsyncT $ modifyData x >> return (Just ())
78+
79+-- | Delete the data item of the given type from the monad state.
80+delSData :: (Monad m, Typeable a) => a -> AsyncT m ()
81+delSData x = AsyncT $ delData x >> return (Just ())
82+
83+------------------------------------------------------------------------------
84+-- MonadState for AsyncT m
85+------------------------------------------------------------------------------
86+
87+instance (Monad m, Monad (AsyncT m)) => MonadState Context (AsyncT m) where
88+ get = AsyncT $ get >>= return . Just
89+ put x = AsyncT $ put x >> return (Just ())
90+ state f = AsyncT $ do
91+ s <- get
92+ let ~(a, s') = f s
93+ put s'
94+ return $ Just a
95+
96+{-
97+-- | Run an action, if the result is a void action undo any state changes
98+-- that it might have caused.
99+try :: MonadIO m => AsyncT m a -> AsyncT m a
100+try mx = do
101+ sd <- gets mfData
102+ mx <|> (modify (\s -> s { mfData = sd }) >> empty)
103+
104+-- | Executes the computation and reset the state either if it fails or not
105+sandbox :: MonadIO m => AsyncT m a -> AsyncT m a
106+sandbox mx = do
107+ sd <- gets mfData
108+ mx <*** modify (\s ->s { mfData = sd})
109+ -}
src/Strands/Threads.hs+6−3
@@ -490,12 +490,15 @@ react setHandler iob = AsyncT $ do
490-- tasks start synchronously in the current thread. New threads are created by
490-- tasks start synchronously in the current thread. New threads are created by
491-- 'parallel', and APIs that use parallel.
491-- 'parallel', and APIs that use parallel.
492threads :: MonadIO m => Int -> AsyncT m a -> AsyncT m a
492threads :: MonadIO m => Int -> AsyncT m a -> AsyncT m a
493−threads n process = do
493+threads n process = AsyncT $ do
494 oldCr <- gets threadCredit
494 oldCr <- gets threadCredit
495 newCr <- liftIO $ newIORef n
495 newCr <- liftIO $ newIORef n
496 modify $ \s -> s { threadCredit = newCr }
496 modify $ \s -> s { threadCredit = newCr }
497− r <- process
497+ r <- runAsyncT $ process
498+ <** (AsyncT $ do
498− <** (modify $ \s -> s { threadCredit = oldCr }) -- restore old credit
499+ modify $ \s -> s { threadCredit = oldCr }
500+ return (Just ())
501+ ) -- restore old credit
499 return r
502 return r
500
503
501{-
504{-