mstate 0.1.3 → 0.2
raw patch · 2 files changed
+66/−59 lines, 2 filesdep +monad-peeldep +stmdep ~mtlPVP ok
version bump matches the API change (PVP)
Dependencies added: monad-peel, stm
Dependency ranges changed: mtl
API changes (from Hackage documentation)
- Control.Concurrent.MState: class MonadIO m => Forkable m
+ Control.Concurrent.MState: class MonadPeelIO m => Forkable m
Files
- mstate.cabal +5/−3
- src/Control/Concurrent/MState.hs +61/−56
mstate.cabal view
@@ -8,7 +8,7 @@ Author: Nils Schweinsberg Maintainer: <mail@n-sch.de> -Version: 0.1.3+Version: 0.2 Category: Concurrent, Monads License: BSD3 License-File: LICENSE@@ -19,8 +19,10 @@ GHC-Options: -Wall Hs-Source-Dirs: src Build-Depends:- base == 4.*,- mtl == 1.*+ base == 4.*,+ mtl == 2.*,+ stm == 2.*,+ monad-peel == 0.1.* Exposed-Modules: Control.Concurrent.MState
src/Control/Concurrent/MState.hs view
@@ -10,7 +10,7 @@ -- Stability : unstable -- Portability : portable ----- MState: A consistent State monad for concurrent applications.+-- MState: A consistent state monad for concurrent applications. -- --------------------------------------------------------------------------- @@ -33,7 +33,7 @@ -- $example ) where -import Control.Monad+ import Control.Monad.State.Class import Control.Monad.Cont import Control.Monad.Error@@ -41,22 +41,29 @@ import Control.Monad.Writer import Control.Concurrent+import Control.Concurrent.STM -import qualified Control.Exception as E+import Control.Monad.IO.Peel+import Control.Exception.Peel -- | The MState is an abstract data definition for a State monad which can be--- used in concurrent applications. It can be accessed with @evalMState@ and--- @execMState@. To start a new state thread use @forkM@.-newtype MState t m a = MState { runMState' :: (MVar t, Chan (MVar ())) -> m a }+-- used in concurrent applications. Use `forkM` to start a new thread with the+-- same state.+newtype MState t m a = MState { runMState' :: (TVar t, TVar [TMVar ()]) -> m a } --- | The class which is needed to start new threads in the MState monad. Don't--- confuse this with @forkM@ which should be used to fork new threads!-class (MonadIO m) => Forkable m where+-- | Typeclass for forkable monads, for instance:+--+-- > instance Forkable IO where+-- > fork = forkIO+--+-- This is only the basic information about how to fork a new thread in the+-- current monad. To start a new thread in a `MState` application you should+-- always use `forkM`.+class (MonadPeelIO m) => Forkable m where fork :: m () -> m ThreadId - instance Forkable IO where fork = forkIO @@ -64,46 +71,33 @@ fork newT = ask >>= liftIO . forkIO . runReaderT newT -catchMVar :: IO a -> (E.BlockedIndefinitelyOnMVar -> IO a) -> IO a-catchMVar = E.catch----- | Read the Chan full of MVars and wait for all MVars to get filled by the--- threads. On MVar-exception this will skip the current MVar and take the next--- one (if available).+-- | Wait for all `TMVars` to get filled by their processes waitForTermination :: MonadIO m- => Chan (MVar ())+ => TVar [TMVar ()] -> m ()-waitForTermination c = liftIO $ do- empty <- isEmptyChan c- catchMVar (unless empty $ do -- Read next threads MVar and wait until it's filled- mv <- readChan c- _ <- takeMVar mv- waitForTermination c)- (const $ return ())-+waitForTermination = liftIO . atomically . (mapM_ takeTMVar <=< readTVar) --- | Run the MState and return both, the function value and the state value+-- | Run a `MState` application, returning both, the function value and the+-- final state runMState :: Forkable m- => MState t m a -- ^ Action to evaluate+ => MState t m a -- ^ Action to run -> t -- ^ Initial state value -> m (a,t) runMState m t = do - ref <- liftIO $ newMVar t- c <- liftIO newChan+ ref <- liftIO $ newTVarIO t+ c <- liftIO $ newTVarIO [] mv <- liftIO newEmptyMVar _ <- runMState' (forkM $ m >>= liftIO . putMVar mv) (ref, c) waitForTermination c a <- liftIO $ takeMVar mv- t' <- liftIO $ readMVar ref+ t' <- liftIO . atomically $ readTVar ref return (a,t') --- | Evaluate the MState monad with the given initial state, throwing away the--- final state stored in the MVar.+-- | Run a `MState` application, ignoring the final state evalMState :: Forkable m => MState t m a -- ^ Action to evaluate -> t -- ^ Initial state value@@ -111,8 +105,7 @@ evalMState m t = runMState m t >>= return . fst --- | Execute the MState monad with a given initial state. Returns the value of--- the final state.+-- | Run a `MState` application, ignoring the function value execMState :: Forkable m => MState t m a -- ^ Action to execute -> t -- ^ Initial state value@@ -121,7 +114,7 @@ -- | Map a stateful computation from one @(return value, state)@ pair to--- another. See @Control.Monad.State.Lazy.mapState@ for more information.+-- another. See "Control.Monad.State.Lazy" for more information. mapMState :: (MonadIO m, MonadIO n) => (m (a,t) -> n (b,t)) -> MState t m a@@ -129,38 +122,51 @@ mapMState f m = MState $ \s@(r,_) -> do ~(b,v') <- f $ do a <- runMState' m s- v <- liftIO $ readMVar r+ v <- liftIO . atomically $ readTVar r return (a,v)- _ <- liftIO $ swapMVar r v'+ liftIO . atomically $ writeTVar r v' return b --- | Apply this function to this state and return the resulting state.+-- | Apply a function to the state before running the `MState` withMState :: (MonadIO m) => (t -> t) -> MState t m a -> MState t m a withMState f m = MState $ \s@(r,_) -> do- liftIO $ modifyMVar_ r (return . f)+ liftIO . atomically $ do+ v <- readTVar r+ writeTVar r (f v) runMState' m s --- | Start a new thread, using @forkIO@. The main process will wait for all--- child processes to finish.++-- | Modify the MState, block all other threads from accessing the state in the+-- meantime.+modifyM :: (MonadIO m) => (t -> t) -> MState t m ()+modifyM f = MState $ \(t,_) ->+ liftIO . atomically $ do+ v <- readTVar t+ writeTVar t (f v)+++-- | Start a new thread, using the `fork` function from the `Forkable` type+-- class. When using this function, the main process will wait for all child+-- processes to finish. forkM :: Forkable m => MState t m () -- ^ State action to be forked -> MState t m ThreadId forkM m = MState $ \s@(_,c) -> do -- Add new thread MVar to our waiting channel- w <- liftIO newEmptyMVar- liftIO $ writeChan c w- fork $ runMState' m s >> liftIO (putMVar w ())-+ w <- liftIO newEmptyTMVarIO+ liftIO . atomically $ do+ r <- readTVar c+ writeTVar c (w:r) --- | Modify the MState. Block all other threads from accessing the state.-modifyM :: (MonadIO m) => (t -> t) -> MState t m ()-modifyM f = MState $ \(t,_) -> liftIO $ modifyMVar_ t (return . f)+ -- Use `finally` to make sure our TMVar gets filled+ fork $+ runMState' m s `finally` liftIO (atomically $ putTMVar w ()) --------------------------------------------------------------------------------@@ -184,9 +190,8 @@ m `mplus` n = MState $ \t -> runMState' m t `mplus` runMState' n t instance (MonadIO m) => MonadState t (MState t m) where- get = MState $ \(r,_) -> liftIO $ readMVar r- put val = MState $ \(r,_) -> do _ <- liftIO $ swapMVar r val- return ()+ get = MState $ \(r,_) -> liftIO . atomically $ readTVar r+ put val = MState $ \(r,_) -> liftIO . atomically $ writeTVar r val instance (MonadFix m) => MonadFix (MState t m) where mfix f = MState $ \s -> mfix $ \a -> runMState' (f a) s@@ -233,23 +238,23 @@ > type MyState a = MState Int IO a > > -- Expected state value: 2+> main :: IO () > main = print =<< execMState incTwice 0 > > incTwice :: MyState () > incTwice = do > -> -- First inc+> -- First increase in the current thread > inc-> > -- This thread should get killed before it can "inc" our state: > kill =<< forkM incDelayed-> -- This thread should "inc" our state+> -- Second increase with a small delay in a forked thread > forkM incDelayed > > return () > > where-> inc = get >>= put . (+1)+> inc = modifyM (+1) > kill = liftIO . killThread > incDelayed = do liftIO $ threadDelay 2000000 > inc