diff --git a/mstate.cabal b/mstate.cabal --- a/mstate.cabal +++ b/mstate.cabal @@ -8,7 +8,7 @@ Author: Nils Schweinsberg Maintainer: -Version: 0.2.2 +Version: 0.2.3 Category: Concurrency, Monads License: BSD3 License-File: LICENSE diff --git a/src/Control/Concurrent/MState.hs b/src/Control/Concurrent/MState.hs --- a/src/Control/Concurrent/MState.hs +++ b/src/Control/Concurrent/MState.hs @@ -29,8 +29,8 @@ , modifyM_ -- * Concurrency - , Forkable (..) , forkM + , forkM_ , killMState -- * Example @@ -39,6 +39,7 @@ import Prelude hiding (catch) +import Control.Applicative import Control.Monad.State.Class import Control.Monad.Cont import Control.Monad.Error @@ -57,12 +58,6 @@ -- new thread sharing the same (modifiable) state use the `forkM` function. newtype MState t m a = MState { runMState' :: (TVar t, TVar [(ThreadId, TMVar ())]) -> m a } --- | Typeclass for forkable monads. This is 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 MonadIO m => Forkable m where - fork :: m () -> m ThreadId - -- | Wait for all `TMVars` to get filled by their processes. waitForTermination :: MonadIO m => TVar [(ThreadId, TMVar ())] @@ -72,7 +67,7 @@ -- | Run a `MState` application, returning both, the function value and the -- final state. Note that this function has to wait for all threads to finish -- before it can return the final state. -runMState :: (Forkable m, MonadPeelIO m) +runMState :: MonadPeelIO m => MState t m a -- ^ Action to run -> t -- ^ Initial state value -> m (a,t) @@ -80,7 +75,7 @@ (a, Just t') <- runAndWaitMaybe True m t return (a, t') -runAndWaitMaybe :: (Forkable m, MonadPeelIO m) +runAndWaitMaybe :: MonadPeelIO m => Bool -> MState t m a -> t @@ -95,7 +90,7 @@ if b then do -- wait before getting the final state waitForTermination c - t' <- liftIO . atomically $ readTVar ref + t' <- liftIO $ readTVarIO ref return (a, Just t') else -- don't wait for other threads @@ -105,7 +100,7 @@ -- argument is `True` this function will wait for all threads to finish before -- returning the final result, otherwise it will return the function value as -- soon as its acquired. -evalMState :: (Forkable m, MonadPeelIO m) +evalMState :: MonadPeelIO m => Bool -- ^ Wait for all threads to finish? -> MState t m a -- ^ Action to evaluate -> t -- ^ Initial state value @@ -114,7 +109,7 @@ -- | Run a `MState` application, ignoring the function value. This function -- will wait for all threads to finish before returning the final state. -execMState :: (Forkable m, MonadPeelIO m) +execMState :: MonadPeelIO m => MState t m a -- ^ Action to execute -> t -- ^ Initial state value -> m t @@ -130,7 +125,7 @@ mapMState f m = MState $ \s@(r,_) -> do ~(b,v') <- f $ do a <- runMState' m s - v <- liftIO . atomically $ readTVar r + v <- liftIO $ readTVarIO r return (a,v) liftIO . atomically $ writeTVar r v' return b @@ -150,8 +145,8 @@ -} --- | Modify the MState, block all other threads from accessing the state in the --- meantime (using `atomically` from the "Control.Concurrent.STM" library). +-- | Modify the `MState`, block all other threads from accessing the state in +-- the meantime (using `atomically` from the "Control.Concurrent.STM" library). modifyM :: MonadIO m => (t -> (a,t)) -> MState t m a modifyM f = MState $ \(t,_) -> liftIO . atomically $ do @@ -163,11 +158,14 @@ modifyM_ :: MonadIO m => (t -> t) -> MState t m () modifyM_ f = modifyM (\t -> ((), f t)) --- | 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 (if desired). -forkM :: (MonadPeelIO m, Forkable m) - => MState t m () -- ^ State action to be forked +fork :: MonadPeelIO m => m () -> m ThreadId +fork m = do + k <- peelIO + liftIO . forkIO $ k m >> return () + +-- | Start a new stateful thread. +forkM :: MonadPeelIO m + => MState t m () -> MState t m ThreadId forkM m = MState $ \s@(_,c) -> do @@ -184,10 +182,17 @@ return tid +forkM_ :: MonadPeelIO m + => MState t m () + -> MState t m () +forkM_ m = do + _ <- forkM m + return () + -- | Kill all threads in the current `MState` application. -killMState :: Forkable m => MState t m () +killMState :: MonadPeelIO m => MState t m () killMState = MState $ \(_,tv) -> do - tms <- liftIO . atomically $ readTVar tv + tms <- liftIO $ readTVarIO tv -- run this in a new thread so it doesn't kill itself _ <- liftIO . forkIO $ mapM_ (killThread . fst) tms @@ -204,17 +209,19 @@ runMState' (k a) t fail str = MState $ \_ -> fail str -instance (Monad m) => Functor (MState t m) where - fmap f m = MState $ \t -> do - a <- runMState' m t - return (f a) +instance (Functor f) => Functor (MState t f) where + fmap f m = MState $ \t -> fmap f (runMState' m t) +instance (Applicative m, Monad m) => Applicative (MState t m) where + pure = return + (<*>) = ap + instance (MonadPlus m) => MonadPlus (MState t m) where mzero = MState $ \_ -> mzero 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 . atomically $ readTVar r + get = MState $ \(r,_) -> liftIO $ readTVarIO r put val = MState $ \(r,_) -> liftIO . atomically $ writeTVar r val instance (MonadFix m) => MonadFix (MState t m) where @@ -260,19 +267,6 @@ instance MonadPeelIO m => MonadPeelIO (MState t m) where peelIO = liftPeel peelIO - --------------------------------------------------------------------------------- --- Forkable instances --------------------------------------------------------------------------------- - -instance Forkable IO where - fork = forkIO - -instance Forkable m => Forkable (ReaderT s m) where - fork newT = ask >>= lift . fork . runReaderT newT - -instance (Error e, Forkable m) => Forkable (ErrorT e m) where - fork newT = lift . fork $ runErrorT newT >> return () {- $example