git.iko.soy/streamly
on master help sign in
Move the user state related stuff out of Context.hs
467a301Harendra Kumar
src/Strands/Context.hs+4−44
compare with master
unifiedsplit
@@ -15,22 +15,16 @@ module Strands.Context
15 , Location(..)
15 , Location(..)
16 , getLocation
16 , getLocation
17 , setLocation
17 , setLocation
18− , getData
19− , setData
20− , modifyData
21− , delData
22 )
18 )
23where
19where
24
20
25import Control.Concurrent (ThreadId)
21import Control.Concurrent (ThreadId)
26import Control.Concurrent.STM (TChan)
22import Control.Concurrent.STM (TChan)
27import Control.Exception (SomeException)
23import Control.Exception (SomeException)
28−import Control.Monad.State (MonadState, gets, modify, StateT,
24+import Control.Monad.State (StateT, MonadPlus(..), MonadIO(..))
29− MonadPlus(..), MonadIO(..))
30import qualified Control.Monad.Trans.State.Lazy as Lazy (get, gets, modify, put)
25import qualified Control.Monad.Trans.State.Lazy as Lazy (get, gets, modify, put)
31−import Data.Dynamic (TypeRep, Typeable, typeOf)
26+import Data.Dynamic (Typeable)
32import Data.IORef (IORef)
27import Data.IORef (IORef)
33−import qualified Data.Map as M
34import Data.Maybe (fromJust)
28import Data.Maybe (fromJust)
35import Unsafe.Coerce (unsafeCoerce)
29import Unsafe.Coerce (unsafeCoerce)
36import GHC.Prim (Any)
30import GHC.Prim (Any)
@@ -72,7 +66,7 @@ data Context = Context
72 -- User state
66 -- User state
73 ---------------------------------------------------------------------------
67 ---------------------------------------------------------------------------
74
68
75− , mfData :: M.Map TypeRep Any -- untyped, type coerced
69+ -- , mfData :: M.Map TypeRep Any -- untyped, type coerced
76 -- ^ State data accessed with get or put operations
70 -- ^ State data accessed with get or put operations
77
71
78 ---------------------------------------------------------------------------
72 ---------------------------------------------------------------------------
@@ -141,7 +135,7 @@ initContext x childChan pending credit finalizer results =
141 , currentm = unsafeCoerce x
135 , currentm = unsafeCoerce x
142 , fstack = [unsafeCoerce finalizer]
136 , fstack = [unsafeCoerce finalizer]
143 , location = Worker
137 , location = Worker
144− , mfData = mempty
138+ -- , mfData = mempty
145 , parentChannel = Nothing
139 , parentChannel = Nothing
146 , childChannel = unsafeCoerce childChan
140 , childChannel = unsafeCoerce childChan
147 , pendingThreads = pending
141 , pendingThreads = pending
@@ -240,37 +234,3 @@ getCtxResultDest :: Context -> Either (TChan (ChildEvent a)) (IORef [a])
240getCtxResultDest ctx =
234getCtxResultDest ctx =
241 maybe (Right $ unsafeCoerce $ fromJust $ accumResults ctx)
235 maybe (Right $ unsafeCoerce $ fromJust $ accumResults ctx)
242 (Left . unsafeCoerce) (parentChannel ctx)
236 (Left . unsafeCoerce) (parentChannel ctx)
243−
244−------------------------------------------------------------------------------
245−-- * Extensible State: Session Data Management
246−------------------------------------------------------------------------------
247−
248−-- | Same as 'getSData' but with a more general type. If the data is found, a
249−-- 'Just' value is returned. Otherwise, a 'Nothing' value is returned.
250−getData :: (MonadState Context m, Typeable a) => m (Maybe a)
251−getData = resp
252− where resp = do
253− list <- gets mfData
254− case M.lookup (typeOf $ typeResp resp) list of
255− Just x -> return . Just $ unsafeCoerce x
256− Nothing -> return Nothing
257− typeResp :: m (Maybe x) -> x
258− typeResp = undefined
259−
260−-- | Same as 'setSData' but with a more general type.
261−setData :: (MonadState Context m, Typeable a) => a -> m ()
262−setData x = modify $ \st -> st { mfData = M.insert t (unsafeCoerce x) (mfData st) }
263− where t = typeOf x
264−
265−modifyData :: (MonadState Context m, Typeable a) => (Maybe a -> Maybe a) -> m ()
266−modifyData f = modify $ \st -> st { mfData = M.alter alterf t (mfData st) }
267− where typeResp :: (Maybe a -> b) -> a
268− typeResp = undefined
269− t = typeOf (typeResp f)
270− alterf mx = unsafeCoerce $ f x'
271− where x' = case mx of
272− Just x -> Just $ unsafeCoerce x
273− Nothing -> Nothing
274−
275−delData :: (MonadState Context m, Typeable a) => a -> m ()
276−delData x = modify $ \st -> st { mfData = M.delete (typeOf x) (mfData st) }
src/Strands/State.hs+41−2
@@ -11,6 +11,10 @@
11
11
12module Strands.State
12module Strands.State
13 (
13 (
14+ getData
15+ , setData
16+ , modifyData
17+ , delData
14 )
18 )
15where
19where
16
20
@@ -19,13 +23,14 @@ import Control.Monad.Base (MonadBase (..), liftBaseDefault)
19import Control.Monad.Catch (MonadThrow, throwM)
23import Control.Monad.Catch (MonadThrow, throwM)
20import Control.Monad.State (MonadIO (..), MonadPlus (..),
24import Control.Monad.State (MonadIO (..), MonadPlus (..),
21 MonadState (..), StateT (..),
25 MonadState (..), StateT (..),
22− liftM, modify, runStateT, when)
26+ liftM, gets, modify, runStateT, when)
23import Control.Monad.Trans.Class (MonadTrans (lift))
27import Control.Monad.Trans.Class (MonadTrans (lift))
24import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
28import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
25 MonadTransControl (..),
29 MonadTransControl (..),
26 defaultLiftBaseWith,
30 defaultLiftBaseWith,
27 defaultRestoreM)
31 defaultRestoreM)
28−import Data.Dynamic (Typeable)
32+import Data.Dynamic (TypeRep, Typeable, typeOf)
33+import qualified Data.Map as M
29
34
30import Strands.Context
35import Strands.Context
31
36
@@ -33,6 +38,40 @@ import Strands.Context
33-- * Extensible State: Session Data Management
38-- * Extensible State: Session Data Management
34------------------------------------------------------------------------------
39------------------------------------------------------------------------------
35
40
41+-- | Same as 'getSData' but with a more general type. If the data is found, a
42+-- 'Just' value is returned. Otherwise, a 'Nothing' value is returned.
43+getData :: (MonadState Context m, Typeable a) => m (Maybe a)
44+getData = resp
45+ where resp = do
46+ list <- gets mfData
47+ case M.lookup (typeOf $ typeResp resp) list of
48+ Just x -> return . Just $ unsafeCoerce x
49+ Nothing -> return Nothing
50+ typeResp :: m (Maybe x) -> x
51+ typeResp = undefined
52+
53+-- | Same as 'setSData' but with a more general type.
54+setData :: (MonadState Context m, Typeable a) => a -> m ()
55+setData x = modify $ \st -> st { mfData = M.insert t (unsafeCoerce x) (mfData st) }
56+ where t = typeOf x
57+
58+modifyData :: (MonadState Context m, Typeable a) => (Maybe a -> Maybe a) -> m ()
59+modifyData f = modify $ \st -> st { mfData = M.alter alterf t (mfData st) }
60+ where typeResp :: (Maybe a -> b) -> a
61+ typeResp = undefined
62+ t = typeOf (typeResp f)
63+ alterf mx = unsafeCoerce $ f x'
64+ where x' = case mx of
65+ Just x -> Just $ unsafeCoerce x
66+ Nothing -> Nothing
67+
68+delData :: (MonadState Context m, Typeable a) => a -> m ()
69+delData x = modify $ \st -> st { mfData = M.delete (typeOf x) (mfData st) }
70+
71+------------------------------------------------------------------------------
72+-- * Extensible State: Session Data Management
73+------------------------------------------------------------------------------
74+
36-- | Retrieve a previously stored data item of the given data type from the
75-- | 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
76-- monad state. The data type to retrieve is implicitly determined from the
38-- requested type context.
77-- requested type context.