stm-io-hooks 0.6.0 → 0.7.0
raw patch · 4 files changed
+70/−26 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Control.Concurrent.AdvSTM: instance Exception e => MonadError e AdvSTM
- Control.Concurrent.AdvSTM: unsafeIOToAdvSTM :: IO a -> AdvSTM a
+ Control.Concurrent.AdvSTM: onCommitWith :: MonadAdvSTM m => ([IO ()] -> IO ()) -> m ()
+ Control.Concurrent.AdvSTM: unsafeIOToSTM :: MonadAdvSTM m => IO a -> m a
+ Control.Monad.AdvSTM: onCommitWith :: MonadAdvSTM m => ([IO ()] -> IO ()) -> m ()
+ Control.Monad.AdvSTM: unsafeIOToSTM :: MonadAdvSTM m => IO a -> m a
Files
- Control/Concurrent/AdvSTM.hs +25/−15
- Control/Monad/AdvSTM/Class.hs +40/−9
- Control/Monad/AdvSTM/Def.hs +3/−0
- stm-io-hooks.cabal +2/−2
Control/Concurrent/AdvSTM.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.AdvSTM@@ -13,7 +14,8 @@ ----------------------------------------------------------------------------- module Control.Concurrent.AdvSTM( -- * Class MonadAdvSTM- MonadAdvSTM( onCommit+ MonadAdvSTM( onCommitWith+ , onCommit , unsafeRetryWith , orElse , retry@@ -32,7 +34,7 @@ -- * Monad AdvSTM , AdvSTM , atomically- , unsafeIOToAdvSTM+ , unsafeIOToSTM , handleSTM , debugAdvSTM , debugMode@@ -54,7 +56,7 @@ import Control.Concurrent.MVar(MVar,newMVar,takeMVar,tryTakeMVar,putMVar,tryPutMVar,swapMVar) import qualified Control.Concurrent.STM as S (STM,orElse,retry,catchSTM,atomically,check,always,alwaysSucceeds) import qualified Control.Concurrent.STM.TVar as STVar -- (TVar,newTVarIO,readTVar,writeTVar)-import GHC.Conc(unsafeIOToSTM)+import qualified GHC.Conc as G -- unsafeIOToSTM import Data.IORef(newIORef,readIORef,writeIORef) import Data.Maybe(isJust,Maybe,fromJust) import Control.Monad.Reader(MonadReader(..),ReaderT(ReaderT),runReaderT,lift,asks)@@ -62,7 +64,12 @@ -------------------------------------------------------------------------------- -instance MonadAdvSTM AdvSTM where+instance MonadAdvSTM (AdvSTM) where++ onCommitWith ioclosure = do+ commitCl <- AdvSTM $ asks commitClosure+ liftAdv $ STVar.writeTVar commitCl ioclosure+ onCommit ioaction = do commitVar <- AdvSTM $ asks commitTVar commitActions <- liftAdv $ STVar.readTVar commitVar@@ -158,7 +165,7 @@ -- | Forks a separate thread to run the IO action and then retries the transaction. unsafeRetryWith io = do -- unsafeOnRetry io >> retry doneMVar <- AdvSTM $ asks retryDoneMVar- unsafeIOToAdvSTM $ forkIO $ (do+ unsafeIOToSTM $ forkIO $ (do val <- takeMVar doneMVar case val of Nothing -> return ()@@ -166,6 +173,8 @@ ) `finally` tryPutMVar doneMVar (Just ()) retry + unsafeIOToSTM = liftAdv . G.unsafeIOToSTM+ -------------------------------------------------------------------------------- @@ -179,9 +188,12 @@ debug (show (tid,"Starting transaction...")) 1000000 debugging -- Building the Reader monad environment commitVar <- STVar.newTVarIO [] -- IO actions to be run if the transaction commits+ commitCl <- STVar.newTVarIO (sequence_) + -- IO action that \"contains\" the commit IO actions. retryDoneMVar <- newMVar $ Just () commitListeners <- STVar.newTVarIO [] let env = Env { commitTVar = commitVar :: STVar.TVar [IO ()] -- -> IO ())+ , commitClosure = commitCl , retryDoneMVar = retryDoneMVar :: MVar (Maybe ()) -- (IO () -> IO ()) , transThreadId = tid :: ThreadId , listeners = commitListeners :: STVar.TVar [(TMVar (),TVarValue)] @@ -220,8 +232,10 @@ stopRetryWith -- Now try to run the onCommit IO actions:- commitAcs <- S.atomically $ STVar.readTVar commitVar- sequence_ [ ac | ac <- commitAcs ] `catch` (\(e::SomeException) -> rollbackOnCommit >> throw e)+ commitAcs <- liftM reverse $ S.atomically $ STVar.readTVar commitVar+ commitClAc <- S.atomically $ STVar.readTVar commitCl+ commitClAc [ ac | ac <- commitAcs ] + `catch` (\(e::SomeException) -> rollbackOnCommit >> throw e) -- Everything's ok, so notify and unblock the TVars: debug (show (tid,"*********************")) 1000000 debugging@@ -238,12 +252,6 @@ -------------------------------------------------------------------------------- --- | See 'unsafeIOToSTM'-unsafeIOToAdvSTM :: IO a -> AdvSTM a-unsafeIOToAdvSTM = liftAdv . unsafeIOToSTM----------------------------------------------------------------------------------- -- | Switches the debug mode on or off. -- /WARNING:/ Can lead to deadlocks! debugMode :: Bool -> AdvSTM ()@@ -287,12 +295,14 @@ -- WARNING: Can lead to deadlocks! debugSTM :: String -> Int -> Bool -> S.STM () debugSTM msg delay debugging = - when debugging $ unsafeIOToSTM $ putStrLn msg >> threadDelay delay+ when debugging $ G.unsafeIOToSTM $ putStrLn msg >> threadDelay delay -- WARNING: Can lead to deadlocks! debug :: String -> Int -> Bool -> IO () debug msg delay debugging = when debugging $ putStrLn msg >> threadDelay delay -instance (Exception e) => MonadError e AdvSTM where+{-+instance forall a. (Exception e, a) => MonadError e (AdvSTM a) where throwError = throw catchError = catchSTM+-}
Control/Monad/AdvSTM/Class.hs view
@@ -41,8 +41,23 @@ -- 'AdvSTM' class Monad m => MonadAdvSTM m where - -- | Takes an IO action that will be executed /iff/ the transaction commits. + -- | Takes a closure IO action and a commit IO action. + -- The commit IO action will be executed /iff/ the transaction commits. + -- Commit actions are sequenced (within the same transaction), i.e.,+ --+ -- > onCommitWith id (putStr "hello")+ -- > onCommitWith id (putStr " world")+ --+ -- will print \"hello world\". -- + -- The closure action is useful for encapsulating the commit actions,+ -- e.g., within a database transaction.+ -- The last call of onCommitWith in the transaction + -- is applied to the sequence of commit actions, i.e.:+ --+ -- > onCommitWith id (putStr "hello")+ -- > onCommitWith (\s -> do { putStrLn "start"; s; putStrLn "\nend"}) (putStr " world")+ -- -- * 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 is dispatched. @@ -65,8 +80,12 @@ -- -- 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 ()+ onCommitWith :: ([IO ()] -> IO ()) -- ^ closure action+ -> m ()+ -- | Works like 'onCommitWith' without closure action:+ -- 'onCommit = onCommitWith id'+ onCommit :: IO () -> m ()+-- onCommit = onCommitWith sequence_ -- | Retries the transaction and uses 'unsafeIOToSTM' to fork off a -- thread that runs the given IO action. Since a transaction might be rerun@@ -96,8 +115,8 @@ -- | Lifts STM actions to 'MonadAdvSTM'. liftAdv :: S.STM a -> m a - -- | Reads a value from a TVar. Blocks until the IO onCommit action(s) of - -- the corresponding transaction are complete.+ -- | Reads a value from a TVar. Blocks until the IO onCommit aidction(s) of + -- the corresponding transaction are complete.is not the last function -- See 'onCommit' for a more detailed description of this behaviour. readTVar :: TVar a -> m a @@ -119,8 +138,9 @@ newTVar :: a -> m (TVar a) -- -- See 'S.atomically'--- runAtomic :: m a -> IO a+-- runAtomic :: m a -> IO aid -- newTVarIO :: a -> IO (TVar a)+ unsafeIOToSTM :: IO a -> m a -- | A version of 'catchSTM' with the arguments swapped around. handleSTM :: (MonadAdvSTM m, Exception e) => (e -> m a) -> m a -> m a@@ -140,8 +160,11 @@ return (r,s) instance MonadAdvSTM m => MonadAdvSTM (StateT s m) where- onCommit = lift . onCommit + onCommit ca = lift (onCommit ca)++ onCommitWith cc = lift (onCommitWith cc)+ unsafeRetryWith = lift . unsafeRetryWith orElse = mapStateT2 orElse@@ -169,6 +192,8 @@ newTVar = lift . newTVar + unsafeIOToSTM = lift . unsafeIOToSTM+ -------------------------------------------------------------------------------- mapWriterT2 :: (m (a, w) -> n (b, w) -> o (c,w)) @@ -190,8 +215,10 @@ return (r,mempty) instance (MonadAdvSTM m, Monoid w) => MonadAdvSTM (WriterT w m) where- onCommit = lift . onCommit + onCommit ca = lift (onCommit ca) + onCommitWith cc = lift (onCommitWith cc)+ unsafeRetryWith = lift . unsafeRetryWith orElse = mapWriterT2 orElse@@ -219,14 +246,17 @@ newTVar = lift . newTVar + unsafeIOToSTM = lift . unsafeIOToSTM -------------------------------------------------------------------------------- mapReaderT2 :: (m a -> n b -> o c) -> ReaderT r m a -> ReaderT r n b -> ReaderT r o c mapReaderT2 f m1 m2 = ReaderT $ \r -> f (runReaderT m1 r) (runReaderT m2 r) instance MonadAdvSTM m => MonadAdvSTM (ReaderT r m) where- onCommit = lift . onCommit + onCommit ca = lift (onCommit ca) + onCommitWith cc = lift (onCommitWith cc)+ unsafeRetryWith = lift . unsafeRetryWith orElse = mapReaderT2 orElse@@ -253,5 +283,6 @@ newTVar = lift . newTVar + unsafeIOToSTM = lift . unsafeIOToSTM --------------------------------------------------------------------------------
Control/Monad/AdvSTM/Def.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving #-}+ ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.AdvSTM.Def@@ -33,6 +35,7 @@ -- | The environment used for the Reader Monad data Env = Env { commitTVar :: TVar [IO ()] -- the commit action(s)+ , commitClosure :: TVar ([IO ()] -> IO ()) , retryDoneMVar :: MVar (Maybe ()) -- (IO () -> IO ()) -- the retry action(s) , transThreadId :: ThreadId -- the current ThreadId , listeners :: TVar [(TMVar (),TVarValue)] -- ,TVar (Maybe ThreadId),TChan (Maybe ThreadId))]
stm-io-hooks.cabal view
@@ -21,12 +21,12 @@ Category: Concurrency Stability: experimental-Author: Peter Robinson 2009, Chris Kuklewicz 2006+Author: Peter Robinson 2009-2010, Chris Kuklewicz 2006 Maintainer: Peter Robinson <thaldyron@gmail.com> License: BSD3 License-file: LICENSE Homepage: http://darcs.monoid.at/stm-io-hooks-Version: 0.6.0+Version: 0.7.0 Build-type: Simple Cabal-Version: >= 1.2.3