stm-io-hooks 0.5.4 → 0.6.0
raw patch · 5 files changed
+52/−18 lines, 5 filesdep ~arraydep ~containersdep ~mtlPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: array, containers, mtl
API changes (from Hackage documentation)
- Control.Concurrent.AdvSTM: instance (Exception e) => MonadError e AdvSTM
- Control.Concurrent.AdvSTM.TArray: instance (MonadAdvSTM m) => MArray TArray e m
+ Control.Concurrent.AdvSTM: instance Exception e => MonadError e AdvSTM
+ Control.Concurrent.AdvSTM: readTVarAsync :: MonadAdvSTM m => TVar a -> m a
+ Control.Concurrent.AdvSTM: writeTVarAsync :: MonadAdvSTM m => TVar a -> a -> m ()
+ Control.Concurrent.AdvSTM.TArray: instance MonadAdvSTM m => MArray TArray e m
+ Control.Concurrent.AdvSTM.TVar: readTVarAsync :: MonadAdvSTM m => TVar a -> m a
+ Control.Concurrent.AdvSTM.TVar: writeTVarAsync :: MonadAdvSTM m => TVar a -> a -> m ()
+ Control.Monad.AdvSTM: readTVarAsync :: MonadAdvSTM m => TVar a -> m a
+ Control.Monad.AdvSTM: writeTVarAsync :: MonadAdvSTM m => TVar a -> a -> m ()
- Control.Concurrent.AdvSTM: always :: (MonadAdvSTM m) => m Bool -> m ()
+ Control.Concurrent.AdvSTM: always :: MonadAdvSTM m => m Bool -> m ()
- Control.Concurrent.AdvSTM: alwaysSucceeds :: (MonadAdvSTM m) => m a -> m ()
+ Control.Concurrent.AdvSTM: alwaysSucceeds :: MonadAdvSTM m => m a -> m ()
- Control.Concurrent.AdvSTM: check :: (MonadAdvSTM m) => Bool -> m ()
+ Control.Concurrent.AdvSTM: check :: MonadAdvSTM m => Bool -> m ()
- Control.Concurrent.AdvSTM: class (Monad m) => MonadAdvSTM m
+ Control.Concurrent.AdvSTM: class Monad m => MonadAdvSTM m
- Control.Concurrent.AdvSTM: liftAdv :: (MonadAdvSTM m) => STM a -> m a
+ Control.Concurrent.AdvSTM: liftAdv :: MonadAdvSTM m => STM a -> m a
- Control.Concurrent.AdvSTM: newTVar :: (MonadAdvSTM m) => a -> m (TVar a)
+ Control.Concurrent.AdvSTM: newTVar :: MonadAdvSTM m => a -> m (TVar a)
- Control.Concurrent.AdvSTM: onCommit :: (MonadAdvSTM m) => IO () -> m ()
+ Control.Concurrent.AdvSTM: onCommit :: MonadAdvSTM m => IO () -> m ()
- Control.Concurrent.AdvSTM: orElse :: (MonadAdvSTM m) => m a -> m a -> m a
+ Control.Concurrent.AdvSTM: orElse :: MonadAdvSTM m => m a -> m a -> m a
- Control.Concurrent.AdvSTM: readTVar :: (MonadAdvSTM m) => TVar a -> m a
+ Control.Concurrent.AdvSTM: readTVar :: MonadAdvSTM m => TVar a -> m a
- Control.Concurrent.AdvSTM: retry :: (MonadAdvSTM m) => m a
+ Control.Concurrent.AdvSTM: retry :: MonadAdvSTM m => m a
- Control.Concurrent.AdvSTM: unsafeRetryWith :: (MonadAdvSTM m) => IO () -> m b
+ Control.Concurrent.AdvSTM: unsafeRetryWith :: MonadAdvSTM m => IO () -> m b
- Control.Concurrent.AdvSTM: writeTVar :: (MonadAdvSTM m) => TVar a -> a -> m ()
+ Control.Concurrent.AdvSTM: writeTVar :: MonadAdvSTM m => TVar a -> a -> m ()
- Control.Concurrent.AdvSTM.TChan: dupTChan :: (MonadAdvSTM m) => TChan a -> m (TChan a)
+ Control.Concurrent.AdvSTM.TChan: dupTChan :: MonadAdvSTM m => TChan a -> m (TChan a)
- Control.Concurrent.AdvSTM.TChan: isEmptyTChan :: (MonadAdvSTM m) => TChan a -> m Bool
+ Control.Concurrent.AdvSTM.TChan: isEmptyTChan :: MonadAdvSTM m => TChan a -> m Bool
- Control.Concurrent.AdvSTM.TChan: newTChan :: (MonadAdvSTM m) => m (TChan a)
+ Control.Concurrent.AdvSTM.TChan: newTChan :: MonadAdvSTM m => m (TChan a)
- Control.Concurrent.AdvSTM.TChan: readTChan :: (MonadAdvSTM m) => TChan a -> m a
+ Control.Concurrent.AdvSTM.TChan: readTChan :: MonadAdvSTM m => TChan a -> m a
- Control.Concurrent.AdvSTM.TChan: unGetTChan :: (MonadAdvSTM m) => TChan a -> a -> m ()
+ Control.Concurrent.AdvSTM.TChan: unGetTChan :: MonadAdvSTM m => TChan a -> a -> m ()
- Control.Concurrent.AdvSTM.TChan: writeTChan :: (MonadAdvSTM m) => TChan a -> a -> m ()
+ Control.Concurrent.AdvSTM.TChan: writeTChan :: MonadAdvSTM m => TChan a -> a -> m ()
- Control.Concurrent.AdvSTM.TMVar: isEmptyTMVar :: (MonadAdvSTM m) => TMVar a -> m Bool
+ Control.Concurrent.AdvSTM.TMVar: isEmptyTMVar :: MonadAdvSTM m => TMVar a -> m Bool
- Control.Concurrent.AdvSTM.TMVar: newEmptyTMVar :: (MonadAdvSTM m) => m (TMVar a)
+ Control.Concurrent.AdvSTM.TMVar: newEmptyTMVar :: MonadAdvSTM m => m (TMVar a)
- Control.Concurrent.AdvSTM.TMVar: newTMVar :: (MonadAdvSTM m) => a -> m (TMVar a)
+ Control.Concurrent.AdvSTM.TMVar: newTMVar :: MonadAdvSTM m => a -> m (TMVar a)
- Control.Concurrent.AdvSTM.TMVar: putTMVar :: (MonadAdvSTM m) => TMVar a -> a -> m ()
+ Control.Concurrent.AdvSTM.TMVar: putTMVar :: MonadAdvSTM m => TMVar a -> a -> m ()
- Control.Concurrent.AdvSTM.TMVar: readTMVar :: (MonadAdvSTM m) => TMVar a -> m a
+ Control.Concurrent.AdvSTM.TMVar: readTMVar :: MonadAdvSTM m => TMVar a -> m a
- Control.Concurrent.AdvSTM.TMVar: swapTMVar :: (MonadAdvSTM m) => TMVar a -> a -> m a
+ Control.Concurrent.AdvSTM.TMVar: swapTMVar :: MonadAdvSTM m => TMVar a -> a -> m a
- Control.Concurrent.AdvSTM.TMVar: takeTMVar :: (MonadAdvSTM m) => TMVar a -> m a
+ Control.Concurrent.AdvSTM.TMVar: takeTMVar :: MonadAdvSTM m => TMVar a -> m a
- Control.Concurrent.AdvSTM.TMVar: tryPutTMVar :: (MonadAdvSTM m) => TMVar a -> a -> m Bool
+ Control.Concurrent.AdvSTM.TMVar: tryPutTMVar :: MonadAdvSTM m => TMVar a -> a -> m Bool
- Control.Concurrent.AdvSTM.TMVar: tryTakeTMVar :: (MonadAdvSTM m) => TMVar a -> m (Maybe a)
+ Control.Concurrent.AdvSTM.TMVar: tryTakeTMVar :: MonadAdvSTM m => TMVar a -> m (Maybe a)
- Control.Concurrent.AdvSTM.TVar: newTVar :: (MonadAdvSTM m) => a -> m (TVar a)
+ Control.Concurrent.AdvSTM.TVar: newTVar :: MonadAdvSTM m => a -> m (TVar a)
- Control.Concurrent.AdvSTM.TVar: readTVar :: (MonadAdvSTM m) => TVar a -> m a
+ Control.Concurrent.AdvSTM.TVar: readTVar :: MonadAdvSTM m => TVar a -> m a
- Control.Concurrent.AdvSTM.TVar: writeTVar :: (MonadAdvSTM m) => TVar a -> a -> m ()
+ Control.Concurrent.AdvSTM.TVar: writeTVar :: MonadAdvSTM m => TVar a -> a -> m ()
- Control.Monad.AdvSTM: always :: (MonadAdvSTM m) => m Bool -> m ()
+ Control.Monad.AdvSTM: always :: MonadAdvSTM m => m Bool -> m ()
- Control.Monad.AdvSTM: alwaysSucceeds :: (MonadAdvSTM m) => m a -> m ()
+ Control.Monad.AdvSTM: alwaysSucceeds :: MonadAdvSTM m => m a -> m ()
- Control.Monad.AdvSTM: check :: (MonadAdvSTM m) => Bool -> m ()
+ Control.Monad.AdvSTM: check :: MonadAdvSTM m => Bool -> m ()
- Control.Monad.AdvSTM: class (Monad m) => MonadAdvSTM m
+ Control.Monad.AdvSTM: class Monad m => MonadAdvSTM m
- Control.Monad.AdvSTM: liftAdv :: (MonadAdvSTM m) => STM a -> m a
+ Control.Monad.AdvSTM: liftAdv :: MonadAdvSTM m => STM a -> m a
- Control.Monad.AdvSTM: newTVar :: (MonadAdvSTM m) => a -> m (TVar a)
+ Control.Monad.AdvSTM: newTVar :: MonadAdvSTM m => a -> m (TVar a)
- Control.Monad.AdvSTM: onCommit :: (MonadAdvSTM m) => IO () -> m ()
+ Control.Monad.AdvSTM: onCommit :: MonadAdvSTM m => IO () -> m ()
- Control.Monad.AdvSTM: orElse :: (MonadAdvSTM m) => m a -> m a -> m a
+ Control.Monad.AdvSTM: orElse :: MonadAdvSTM m => m a -> m a -> m a
- Control.Monad.AdvSTM: readTVar :: (MonadAdvSTM m) => TVar a -> m a
+ Control.Monad.AdvSTM: readTVar :: MonadAdvSTM m => TVar a -> m a
- Control.Monad.AdvSTM: retry :: (MonadAdvSTM m) => m a
+ Control.Monad.AdvSTM: retry :: MonadAdvSTM m => m a
- Control.Monad.AdvSTM: unsafeRetryWith :: (MonadAdvSTM m) => IO () -> m b
+ Control.Monad.AdvSTM: unsafeRetryWith :: MonadAdvSTM m => IO () -> m b
- Control.Monad.AdvSTM: writeTVar :: (MonadAdvSTM m) => TVar a -> a -> m ()
+ Control.Monad.AdvSTM: writeTVar :: MonadAdvSTM m => TVar a -> a -> m ()
Files
- Control/Concurrent/AdvSTM.hs +13/−7
- Control/Concurrent/AdvSTM/TVar.hs +4/−1
- Control/Monad/AdvSTM/Class.hs +28/−3
- Control/Monad/AdvSTM/Def.hs +2/−2
- stm-io-hooks.cabal +5/−5
Control/Concurrent/AdvSTM.hs view
@@ -23,6 +23,8 @@ , catchSTM , liftAdv , newTVar+ , readTVarAsync+ , writeTVarAsync , readTVar , writeTVar )@@ -62,9 +64,9 @@ instance MonadAdvSTM AdvSTM where onCommit ioaction = do- commitVar <- AdvSTM $ asks commitTVar- commitFun <- liftAdv $ STVar.readTVar commitVar- liftAdv $ STVar.writeTVar commitVar $ commitFun . (ioaction >>)+ commitVar <- AdvSTM $ asks commitTVar+ commitActions <- liftAdv $ STVar.readTVar commitVar+ liftAdv $ STVar.writeTVar commitVar $ ioaction : commitActions -- unsafeOnRetry ioaction = do -- retryVar <- AdvSTM $ asks retryMVar@@ -128,6 +130,8 @@ liftAdv $ putTMVar (onCommitLock tvar) () + writeTVarAsync tvar = liftAdv . STVar.writeTVar (valueTVar tvar) + -------------------------------------------------------------------------------- -- | Reads a value from a TVar. Blocks until the IO onCommit action(s) of @@ -148,7 +152,9 @@ return result + readTVarAsync = liftAdv . STVar.readTVar . valueTVar + -- | Forks a separate thread to run the IO action and then retries the transaction. unsafeRetryWith io = do -- unsafeOnRetry io >> retry doneMVar <- AdvSTM $ asks retryDoneMVar@@ -172,10 +178,10 @@ debug "***************************************************************" 0 debugging debug (show (tid,"Starting transaction...")) 1000000 debugging -- Building the Reader monad environment- commitVar <- STVar.newTVarIO id -- IO actions to be run if the transaction commits+ commitVar <- STVar.newTVarIO [] -- IO actions to be run if the transaction commits retryDoneMVar <- newMVar $ Just () commitListeners <- STVar.newTVarIO [] - let env = Env { commitTVar = commitVar :: STVar.TVar (IO () -> IO ())+ let env = Env { commitTVar = commitVar :: STVar.TVar [IO ()] -- -> IO ()) , retryDoneMVar = retryDoneMVar :: MVar (Maybe ()) -- (IO () -> IO ()) , transThreadId = tid :: ThreadId , listeners = commitListeners :: STVar.TVar [(TMVar (),TVarValue)] @@ -214,8 +220,8 @@ stopRetryWith -- Now try to run the onCommit IO actions:- commitFun <- S.atomically $ STVar.readTVar commitVar- commitFun (return ()) `catch` (\(e::SomeException) -> rollbackOnCommit >> throw e)+ commitAcs <- S.atomically $ STVar.readTVar commitVar+ sequence_ [ ac | ac <- commitAcs ] `catch` (\(e::SomeException) -> rollbackOnCommit >> throw e) -- Everything's ok, so notify and unblock the TVars: debug (show (tid,"*********************")) 1000000 debugging
Control/Concurrent/AdvSTM/TVar.hs view
@@ -18,9 +18,12 @@ , newTVarIO , readTVar , writeTVar+ , readTVarAsync+ , writeTVarAsync ) where-import Control.Monad.AdvSTM.Class(readTVar,writeTVar,newTVar,TVar(TVar))+import Control.Monad.AdvSTM.Class+ (readTVar,writeTVar,newTVar,TVar(TVar),valueTVar,readTVarAsync,writeTVarAsync) import qualified Control.Concurrent.STM.TVar as OldTVar import qualified Control.Concurrent.STM.TMVar as OldTMVar import Control.Monad(liftM,ap)
Control/Monad/AdvSTM/Class.hs view
@@ -43,9 +43,9 @@ -- | Takes an IO action that will be executed /iff/ the transaction commits. -- - -- * When a TVar was modified in a transaction and this transaction commits,+ -- * When a TVar was modified in a transaction and the transaction tries to commit, -- this update remains invisible to other threads until the corresponding - -- onCommit action was run. + -- onCommit action is dispatched. -- -- * If the onCommit action throws an exception, the original value of -- the TVars will be restored.@@ -63,6 +63,8 @@ -- > x <- readTVar tvar -- > onCommit (writeFile "myfile" x) -- + -- Note: If you /really/ need to access the 'TVar' within an onCommit action+ -- (e.g. to recover from an IO exception), you can use 'writeTVarAsync'. -- onCommit :: IO () -> m () @@ -103,6 +105,16 @@ -- complete. See 'onCommit' for details. writeTVar :: TVar a -> a -> m () + -- | Reads a value directly from the TVar. Does not block when the+ -- onCommit actions aren't done yet. NOTE: Only use this function when+ -- you know what you're doing.+ readTVarAsync :: TVar a -> m a ++ -- | Writes a value directly to the TVar. Does not block when + -- onCommit actions aren't done yet. This function comes in handy for+ -- error recovery of exceptions that occur in onCommit.+ writeTVarAsync :: TVar a -> a -> m ()+ -- | See 'OldTVar.newTVar' newTVar :: a -> m (TVar a) @@ -151,6 +163,10 @@ writeTVar tvar = lift . writeTVar tvar + readTVarAsync = lift . readTVarAsync++ writeTVarAsync tvar = lift . writeTVarAsync tvar+ newTVar = lift . newTVar --------------------------------------------------------------------------------@@ -197,6 +213,10 @@ writeTVar tvar = lift . writeTVar tvar + readTVarAsync = lift . readTVarAsync++ writeTVarAsync tvar = lift . writeTVarAsync tvar+ newTVar = lift . newTVar --------------------------------------------------------------------------------@@ -222,9 +242,14 @@ liftAdv = lift . liftAdv - readTVar = lift . readTVar + writeTVarAsync tvar = lift . writeTVarAsync tvar++ readTVarAsync = lift . readTVarAsync+ writeTVar tvar = lift . writeTVar tvar++ readTVar = lift . readTVar newTVar = lift . newTVar
Control/Monad/AdvSTM/Def.hs view
@@ -32,9 +32,9 @@ -- | The environment used for the Reader Monad-data Env = Env { commitTVar :: TVar (IO () -> IO ()) -- the commit action(s)+data Env = Env { commitTVar :: TVar [IO ()] -- the commit action(s) , retryDoneMVar :: MVar (Maybe ()) -- (IO () -> IO ()) -- the retry action(s)- , transThreadId :: ThreadId -- the current ThreadId+ , transThreadId :: ThreadId -- the current ThreadId , listeners :: TVar [(TMVar (),TVarValue)] -- ,TVar (Maybe ThreadId),TChan (Maybe ThreadId))] -- Contains communication facilities for modified TVars: -- [(tVar-Lock,Old-tVar-Value,Maybe (current ThreadId)
stm-io-hooks.cabal view
@@ -14,7 +14,7 @@ the modified TVars are restored. . Note: The package can be used as a drop-in replacement for - 'Control.Concurrent.STM'. Part of this library uses code from+ 'Control.Concurrent.STM'. This library was inspired by the AdvSTM monad on the Haskell Wiki (see <http://haskell.org/haskellwiki/?title=New_monads/MonadAdvSTM>). . Feedback is welcome!@@ -26,7 +26,7 @@ License: BSD3 License-file: LICENSE Homepage: http://darcs.monoid.at/stm-io-hooks-Version: 0.5.4+Version: 0.6.0 Build-type: Simple Cabal-Version: >= 1.2.3@@ -44,9 +44,9 @@ build-depends: base >= 4 && < 5 ,stm >= 2.1.1.2 && < 2.2- ,array >= 0.2.0.0 && < 0.3- ,containers >= 0.2.0.0 && < 0.3- ,mtl >= 1.1.0.2 && < 1.2+ ,array >= 0.2.0.0 && < 0.4+ ,containers >= 0.2.0.0 && < 0.4+ ,mtl >= 1.1.0.2 && < 1.3 extensions: MultiParamTypeClasses FunctionalDependencies