git.iko.soy/streamly
on ab91267 help sign in
streamly/src/Asyncly/State.hs
148 lines 6.0 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.State
13 (
14 getData
15 , setData
16 , modifyData
17 , delData
18 )
19where
21import Control.Applicative (Alternative (..))
22import Control.Monad.Base (MonadBase (..), liftBaseDefault)
23import Control.Monad.Catch (MonadThrow, throwM)
24import Control.Monad.State (MonadIO (..), MonadPlus (..),
25 MonadState (..), StateT (..),
26 liftM, gets, modify, runStateT, when)
27import Control.Monad.Trans.Class (MonadTrans (lift))
28import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
29 MonadTransControl (..),
30 defaultLiftBaseWith,
31 defaultRestoreM)
32import Data.Dynamic (TypeRep, Typeable, typeOf)
33import qualified Data.Map as M
35import Strands.Context
37------------------------------------------------------------------------------
38-- * Extensible State: Session Data Management
39------------------------------------------------------------------------------
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.
43getData :: (MonadState Context m, Typeable a) => m (Maybe a)
44getData = 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
53-- | Same as 'setSData' but with a more general type.
54setData :: (MonadState Context m, Typeable a) => a -> m ()
55setData x = modify $ \st -> st { mfData = M.insert t (unsafeCoerce x) (mfData st) }
56 where t = typeOf x
58modifyData :: (MonadState Context m, Typeable a) => (Maybe a -> Maybe a) -> m ()
59modifyData 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
68delData :: (MonadState Context m, Typeable a) => a -> m ()
69delData x = modify $ \st -> st { mfData = M.delete (typeOf x) (mfData st) }
71------------------------------------------------------------------------------
72-- * Extensible State: Session Data Management
73------------------------------------------------------------------------------
75-- | Retrieve a previously stored data item of the given data type from the
76-- monad state. The data type to retrieve is implicitly determined from the
77-- requested type context.
78-- If the data item is not found, an 'empty' value (a void event) is returned.
79-- Remember that an empty value stops the monad computation. If you want to
80-- print an error message or a default value in that case, you can use an
81-- 'Alternative' composition. For example:
82--
83-- > getSData <|> error "no data"
84-- > getInt = getSData <|> return (0 :: Int)
85getSData :: (Monad m, Typeable a) => AsyncT m a
86getSData = AsyncT getData
88-- | 'setSData' stores a data item in the monad state which can be retrieved
89-- later using 'getData' or 'getSData'. Stored data items are keyed by their
90-- data type, and therefore the data type must be 'Typeable' and only one item
91-- of a given type can be stored. A newtype wrapper can be used to distinguish
92-- two data items of the same type when required.
93--
94-- @
95-- import Control.Monad.IO.Class (liftIO)
96-- import Transient.Base
97-- import Data.Typeable
98--
99-- data Person = Person
100-- { name :: String
101-- , age :: Int
102-- } deriving Typeable
103--
104-- main = keep $ do
105-- setSData $ Person "Alberto" 55
106-- Person name age <- getSData
107-- liftIO $ print (name, age)
108-- @
109setSData :: (Monad m, Typeable a) => a -> AsyncT m ()
110setSData x = AsyncT $ setData x >> return (Just ())
112-- | Accepts a function that takes the current value of the stored data type
113-- and returns the modified value. If the function returns 'Nothing' the value
114-- is deleted otherwise updated.
115modifySData :: (Monad m, Typeable a) => (Maybe a -> Maybe a) -> AsyncT m ()
116modifySData x = AsyncT $ modifyData x >> return (Just ())
118-- | Delete the data item of the given type from the monad state.
119delSData :: (Monad m, Typeable a) => a -> AsyncT m ()
120delSData x = AsyncT $ delData x >> return (Just ())
122------------------------------------------------------------------------------
123-- MonadState for AsyncT m
124------------------------------------------------------------------------------
126instance (Monad m, Monad (AsyncT m)) => MonadState Context (AsyncT m) where
127 get = AsyncT $ get >>= return . Just
128 put x = AsyncT $ put x >> return (Just ())
129 state f = AsyncT $ do
130 s <- get
131 let ~(a, s') = f s
132 put s'
133 return $ Just a
135{-
136-- | Run an action, if the result is a void action undo any state changes
137-- that it might have caused.
138try :: MonadIO m => AsyncT m a -> AsyncT m a
139try mx = do
140 sd <- gets mfData
141 mx <|> (modify (\s -> s { mfData = sd }) >> empty)
143-- | Executes the computation and reset the state either if it fails or not
144sandbox :: MonadIO m => AsyncT m a -> AsyncT m a
145sandbox mx = do
146 sd <- gets mfData
147 mx <*** modify (\s ->s { mfData = sd})
148 -}