concurrent-state 0.3.3.2 → 0.4.0.0

raw patch · 5 files changed

+152/−1 lines, 5 files

Files

• changelog +5/−0
• concurrent-state.cabal +2/−1
• src/Control/Concurrent/Lifted/Fork.hs +39/−0
• src/Control/Monad/State/Concurrent/Lazy.hs +53/−0
• src/Control/Monad/State/Concurrent/Strict.hs +53/−0

@@ -1,3 +1,8 @@+0.4.0.0+-------+* MonadFork (adds `exceptions' dependency)+* Helpers for running concurrent operations on one input+ 0.3.3.2 ------- * Add changelog to tarball

@@ -1,5 +1,5 @@ name:                concurrent-state-version:             0.3.3.2+version:             0.4.0.0 synopsis:            MTL-like library using TVars description:         State backed by TVar. homepage:            https://github.com/joelteon/concurrent-state@@ -16,6 +16,7 @@   exposed-modules:     Control.Monad.State.Concurrent                        Control.Monad.State.Concurrent.Lazy                        Control.Monad.State.Concurrent.Strict+                       Control.Concurrent.Lifted.Fork   build-depends:       base >=4.6 && <4.7, exceptions >= 0.3, mtl >= 2.1, stm, transformers   hs-source-dirs:      src   default-language:    Haskell2010

@@ -0,0 +1,39 @@+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------+-- |+-- Maintainer  : me@joelt.io+-- Stability   : experimental+-- Portability : portable+--+-- Generalizes `forkIO' to MonadIO.+-----------------------------------------------------------------------------+module Control.Concurrent.Lifted.Fork (+    MonadFork(..),+    forkFinally+) where++import qualified Control.Concurrent as C+import           Control.Monad.Catch+import           Control.Monad.Reader++-- | Generalize 'forkIO' to 'MonadIO'.+class (MonadIO m, MonadCatch m) => MonadFork m where+    fork :: m () -> m C.ThreadId+    forkOn :: Int -> m () -> m C.ThreadId+    forkOS :: m () -> m C.ThreadId++instance MonadFork IO where+    fork = C.forkIO+    forkOn = C.forkOn+    forkOS = C.forkOS++instance MonadFork m => MonadFork (ReaderT r m) where+    fork (ReaderT m) = ReaderT (fork . m)+    forkOn i (ReaderT m) = ReaderT (forkOn i . m)+    forkOS (ReaderT m) = ReaderT (forkOS . m)++-- | Generalized 'C.forkFinally'.+forkFinally :: MonadFork m => m a -> (Either SomeException a -> m ()) -> m C.ThreadId+forkFinally action andThen = mask $ \restore ->+    fork $ try (restore action) >>= andThen

@@ -16,17 +16,23 @@ ----------------------------------------------------------------------------- module Control.Monad.State.Concurrent.Lazy (     module Control.Monad.State,+    module Control.Concurrent.Lifted.Fork,     -- *** The StateC monad transformer     StateC,      -- *** Concurrent state operations     runStateC, evalStateC, execStateC, +    -- *** Running concurrent operations on a single input+    runStatesC, evalStatesC, execStatesC,+     -- *** Lifting other operations     liftCallCCC, liftCallCCC', liftCatchC, liftListenC, liftPassC ) where  import Control.Applicative+import Control.Concurrent.Lifted.Fork+import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Exception (throwIO) import Control.Monad@@ -101,6 +107,17 @@         StateC $ \tv -> uninterruptibleMask $ \u -> _runStateC (a $ q u) tv where         q u (StateC f) = StateC (u . f) +instance MonadFork m => MonadFork (StateC s m) where+    fork (StateC m) = StateC $ \tv -> do+        tid <- fork (liftM fst $ m tv)+        return (tid, tv)+    forkOn i (StateC m) = StateC $ \tv -> do+        tid <- forkOn i (liftM fst $ m tv)+        return (tid, tv)+    forkOS (StateC m) = StateC $ \tv -> do+        tid <- forkOS (liftM fst $ m tv)+        return (tid, tv)+ -- | Unwrap a concurrent state monad computation as a function. runStateC :: MonadIO m           => StateC s m a -- ^ state-passing computation to execute@@ -167,3 +184,39 @@ liftPassC pass m = StateC $ \tv -> pass $ do     ~((a, f), s') <- _runStateC m tv     return ((a, s'), f)++-- | Run multiple state operations on the same value, returning the+-- resultant state and the value produced by each operation.+runStatesC :: MonadFork m+           => [StateC s m a] -- ^ state-passing computations to execute+           -> s -- ^ initial state+           -> m ([a], s) -- ^ return values and final state+runStatesC ms s = do+    v <- liftIO $ newTVarIO s+    mvs <- mapM (const (liftIO newEmptyMVar)) ms+    forM_ (zip mvs ms) $ \(mv, operation) -> fork $ do+        res <- evalStateC operation v+        liftIO $ putMVar mv res+    items <- forM mvs (liftIO . takeMVar)+    end <- liftIO $ readTVarIO v+    return (items, end)++-- | Run multiple state operations on the same value, returning all values+-- produced by each operation.+--+-- * @'evalStatesC' ms s = 'liftM' 'fst' ('runStatesC' ms s)@+evalStatesC :: MonadFork m+            => [StateC s m a] -- ^ state-passing computations to execute+            -> s -- ^ initial state+            -> m [a] -- ^ return values+evalStatesC ms s = liftM fst $ runStatesC ms s++-- | Run multiple state operations on the same value, returning the+-- resultant state.+--+-- * @'execStatesC' ms s = 'liftM' 'snd' ('runStatesC' ms s)@+execStatesC :: MonadFork m+            => [StateC s m a] -- ^ state-passing computations to execute+            -> s -- ^ initial state+            -> m s -- ^ final state+execStatesC ms s = liftM snd $ runStatesC ms s

@@ -16,18 +16,24 @@ ----------------------------------------------------------------------------- module Control.Monad.State.Concurrent.Strict (     module Control.Monad.State,+    module Control.Concurrent.Lifted.Fork,     -- *** The StateC monad transformer     StateC,      -- *** Concurrent state operations     runStateC, evalStateC, execStateC, +    -- *** Running concurrent operations on a single input+    runStatesC, evalStatesC, execStatesC,+     -- *** Lifting other operations     liftCallCCC, liftCallCCC', liftCatchC, liftListenC, liftPassC ) where  import Control.Applicative import Control.Arrow (first)+import Control.Concurrent.Lifted.Fork+import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Exception (throwIO) import Control.Monad@@ -102,6 +108,17 @@         StateC $ \tv -> uninterruptibleMask $ \u -> _runStateC (a $ q u) tv where         q u (StateC f) = StateC (u . f) +instance MonadFork m => MonadFork (StateC s m) where+    fork (StateC m) = StateC $ \tv -> do+        tid <- fork (liftM fst $ m tv)+        return (tid, tv)+    forkOn i (StateC m) = StateC $ \tv -> do+        tid <- forkOn i (liftM fst $ m tv)+        return (tid, tv)+    forkOS (StateC m) = StateC $ \tv -> do+        tid <- forkOS (liftM fst $ m tv)+        return (tid, tv)+ -- | Unwrap a concurrent state monad computation as a function. runStateC :: MonadIO m           => StateC s m a -- ^ state-passing computation to execute@@ -168,3 +185,39 @@ liftPassC pass m = StateC $ \tv -> pass $ do     ((a, f), s') <- _runStateC m tv     return ((a, s'), f)++-- | Run multiple state operations on the same value, returning the+-- resultant state and the value produced by each operation.+runStatesC :: MonadFork m+           => [StateC s m a] -- ^ state-passing computations to execute+           -> s -- ^ initial state+           -> m ([a], s) -- ^ return values and final state+runStatesC ms s = do+    v <- liftIO $ newTVarIO s+    mvs <- mapM (const (liftIO newEmptyMVar)) ms+    forM_ (zip mvs ms) $ \(mv, operation) -> fork $ do+        res <- evalStateC operation v+        liftIO $ putMVar mv res+    items <- forM mvs (liftIO . takeMVar)+    end <- liftIO $ readTVarIO v+    return (items, end)++-- | Run multiple state operations on the same value, returning all values+-- produced by each operation.+--+-- * @'evalStatesC' ms s = 'liftM' 'fst' ('runStatesC' ms s)@+evalStatesC :: MonadFork m+            => [StateC s m a] -- ^ state-passing computations to execute+            -> s -- ^ initial state+            -> m [a] -- ^ return values+evalStatesC ms s = liftM fst $ runStatesC ms s++-- | Run multiple state operations on the same value, returning the+-- resultant state.+--+-- * @'execStatesC' ms s = 'liftM' 'snd' ('runStatesC' ms s)@+execStatesC :: MonadFork m+            => [StateC s m a] -- ^ state-passing computations to execute+            -> s -- ^ initial state+            -> m s -- ^ final state+execStatesC ms s = liftM snd $ runStatesC ms s