stm-io-hooks 0.3.0 → 0.4.2
raw patch · 3 files changed
+100/−74 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Control.Concurrent.AdvSTM: handleSTM :: (MonadAdvSTM m, Exception e) => (e -> m a) -> m a -> m a
+ Control.Concurrent.AdvSTM: instance (Exception e) => MonadError e AdvSTM
Files
- Control/Concurrent/AdvSTM.hs +24/−24
- Control/Monad/AdvSTM/Class.hs +73/−48
- stm-io-hooks.cabal +3/−2
Control/Concurrent/AdvSTM.hs view
@@ -12,10 +12,6 @@ -- ----------------------------------------------------------------------------- --- TODO: remove type class or add readTVar/writeTVar to type class--- Try to change type of onCommit/retryWith to MonadIO!---- module Control.Concurrent.AdvSTM( -- * Class MonadAdvSTM MonadAdvSTM( onCommit , onRetry@@ -37,19 +33,21 @@ , retryWith , atomically , unsafeIOToAdvSTM+ , handleSTM , debugAdvSTM , debugMode ) where import Prelude hiding (catch) import Control.Monad.AdvSTM.Def(AdvSTM(..),Env(..),TVarValue(..))-import Control.Monad.AdvSTM.Class( MonadAdvSTM(..), TVar( TVar ), onCommitLock, currentTid, valueTVar )+import Control.Monad.AdvSTM.Class( + MonadAdvSTM(..), handleSTM, TVar( TVar ), onCommitLock, currentTid, valueTVar ) -- import Control.Monad.Reader(ReaderT(ReaderT),mapReaderT,runReaderT) -import Control.Exception(throw,catch,SomeException,fromException,try,block,Deadlock(..)) +import Control.Exception(Exception,throw,catch,SomeException,fromException,try,block,Deadlock(..)) import Control.Monad(mplus,when,liftM,ap,unless)-import Control.Monad.Reader(MonadReader(..),ReaderT,runReaderT,lift,asks)-import Control.Concurrent(threadDelay,forkIO,ThreadId,myThreadId)+import Control.Monad.Error(MonadError(..))+import Control.Concurrent(threadDelay,forkIO,ThreadId,myThreadId,throwTo) import Control.Concurrent.Chan(Chan,newChan,readChan,writeChan) import Control.Concurrent.STM.TMVar(TMVar,putTMVar,takeTMVar,newTMVar,tryTakeTMVar) -- import Control.Concurrent.STM.TChan(TChan,writeTChan)@@ -59,6 +57,7 @@ import GHC.Conc(unsafeIOToSTM) import Data.IORef(newIORef,readIORef,writeIORef) import Data.Maybe(isJust,Maybe,fromJust)+import Control.Monad.Reader(MonadReader(..),ReaderT(ReaderT),runReaderT,lift,asks) -------------------------------------------------------------------------------- @@ -91,9 +90,9 @@ catchSTM action handler = do action' <- unlift action handler' <- unlift1 handler- let handler'' = \e -> case fromException e of- Nothing -> throw e- Just e' -> handler' e'+ let handler'' e = case fromException e of+ Nothing -> throw e+ Just e' -> handler' e' liftAdv $ S.catchSTM action' handler'' liftAdv = AdvSTM . lift @@ -113,9 +112,9 @@ curTid <- AdvSTM $ asks transThreadId storedTid <- liftAdv $ STVar.readTVar (currentTid tvar) case commitLock of- Nothing -> do+ Nothing -> if isJust storedTid && fromJust storedTid == curTid- then throw Deadlock -- No transaction during onCommit-phase!+ then throw Deadlock -- Can't write the TVar in the onCommit phase else retry Just _ -> do unless (isJust storedTid && (fromJust storedTid == curTid)) $ do@@ -197,7 +196,7 @@ Nothing -> do chan <- newChan writeIORef retryChanVar (Just chan)- spawn'retry'thread (readChan chan) (putMVar retryEndVar ())+ spawn'retry'thread (readChan chan) (putMVar retryEndVar ()) tid return chan Just chan -> return chan writeChan chan $ Just (retryFun (return()))@@ -214,7 +213,7 @@ writeChan chan Nothing takeMVar retryEndVar - let wrappedAction = runReaderT action env `S.orElse` (check'retry)+ let wrappedAction = runReaderT action env `S.orElse` check'retry -- Block interruptions from other threads for the rest of 'atomically' block $ do @@ -249,7 +248,7 @@ debug (show (tid,"Notifying TPVars that we're done:")) 0 debugging S.atomically $ do ls <- STVar.readTVar commitListeners - mapM_ (\(l,_) -> do + mapM_ (\(l,_) -> putTMVar l () ) ls wait'retry'finished@@ -259,8 +258,8 @@ where -- Helper thread for the retry IO-actions- spawn'retry'thread :: IO (Maybe (IO ())) -> IO () -> IO ThreadId- spawn'retry'thread nextJob atEndAction = forkIO $ loop+ spawn'retry'thread :: IO (Maybe (IO ())) -> IO () -> ThreadId -> IO ThreadId+ spawn'retry'thread nextJob atEndAction mainTId = forkIO loop where loop = do may'job <- nextJob case may'job of@@ -268,7 +267,7 @@ Just job -> do res <- try job case res of- Left (e::SomeException) -> throw e+ Left (e::SomeException) -> throwTo mainTId e Right _ -> loop @@ -320,16 +319,17 @@ unlift1 :: (t -> AdvSTM a) -> AdvSTM (t -> S.STM a) unlift1 f = do u <- unlifter- return (\x -> u (f x))+ return (u . f) -- WARNING: Can lead to deadlocks! debugSTM :: String -> Int -> Bool -> S.STM () debugSTM msg delay debugging = - when (debugging) $ unsafeIOToSTM $ putStrLn msg >> threadDelay delay+ when debugging $ 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--+debug msg delay debugging = when debugging $ putStrLn msg >> threadDelay delay +instance (Exception e) => MonadError e AdvSTM where+ throwError = throw+ catchError = catchSTM
Control/Monad/AdvSTM/Class.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.AdvSTM.Class--- Copyright : (c) HaskellWiki 2006-2007, Peter Robinson 2008+-- Copyright : Peter Robinson 2008, HaskellWiki 2006-2007 -- License : BSD3 -- -- Maintainer : Peter Robinson <robinson@ecs.tuwien.ac.at>@@ -13,18 +13,18 @@ -- MonadAdvSTM (see package description). ----------------------------------------------------------------------------- -module Control.Monad.AdvSTM.Class( MonadAdvSTM(..), TVar(TVar), valueTVar, onCommitLock, currentTid )+module Control.Monad.AdvSTM.Class( MonadAdvSTM(..), handleSTM, TVar(TVar), valueTVar, onCommitLock, currentTid) where -import Control.Exception(Exception)+import Control.Exception(Exception,throw) import qualified Control.Concurrent.STM as S import qualified Control.Concurrent.STM.TVar as OldTVar import qualified Control.Concurrent.STM.TMVar as OldTMVar-import Control.Monad(Monad,liftM)+import Control.Monad(Monad,liftM,ap) import Control.Monad.Trans(lift)-import Control.Monad.Reader(ReaderT(ReaderT),mapReaderT,runReaderT) import Control.Monad.State(StateT(StateT),mapStateT,runStateT,evalStateT) import Control.Monad.Writer(WriterT(WriterT),mapWriterT,runWriterT,execWriterT)+import Control.Monad.Reader(ReaderT(ReaderT),mapReaderT,runReaderT) -- import Control.Monad.AdvSTM.Def(AdvSTM) import Control.Concurrent( ThreadId ) --import GHC.Conc( unsafeIOToSTM )@@ -70,10 +70,14 @@ -- a new helper thread is forked that runs the retry actions, and, after the helper -- thread is done, the transaction retries. -- - -- Uses 'unsafeIOToSTM' to fork a helper thread that runs the retry - -- actions. - onRetry :: IO () -- ^ IO action that will be run on retry the transaction.- -> m ()+ -- /Note:/ When the transaction is retried, 'unsafeIOToSTM' is used to fork a + -- helper thread that runs the retry actions (if any). It is your+ -- responsibility to ensure that your retry IO-actions are ``safe''. Any+ -- exceptions occurring in the retry-thread will be thrown to the+ -- thread where the transaction is running and immediately cause the transaction to be+ -- aborted, since 'catchSTM' does not catch asynchronous exceptions.+ onRetry :: IO () -- ^ IO action that will be run if the transaction is (explicitly) retried.+ -> m () -- | See 'S.orElse' orElse :: m a -> m a -> m a@@ -91,12 +95,10 @@ -- | See 'S.always' always :: m Bool -> m () - -- | Runs a transaction atomically in the 'IO' monad. --- runAtomic :: m a -> IO a- -- | See 'S.catchSTM' catchSTM :: Exception e => m a -> (e -> m a) -> m a + -- | Lifts STM actions to 'MonadAdvSTM'. liftAdv :: S.STM a -> m a @@ -112,30 +114,44 @@ -- | See 'OldTVar.newTVar' newTVar :: a -> m (TVar a) +-- -- See 'S.atomically'+-- runAtomic :: m a -> IO a -- newTVarIO :: a -> IO (TVar a) +-- | A version of 'catchSTM' with the arguments swapped around.+handleSTM :: (MonadAdvSTM m, Exception e) => (e -> m a) -> m a -> m a+handleSTM = flip catchSTM -mapReaderT2 :: (m a -> n b -> o c) -> ReaderT w m a -> ReaderT w n b -> ReaderT w o c-mapReaderT2 f m1 m2 = ReaderT $ \r -> f (runReaderT m1 r) (runReaderT m2 r) -instance MonadAdvSTM m => MonadAdvSTM (ReaderT r m) where+--------------------------------------------------------------------------------+++mapStateT2 :: (m (a, s) -> n (b, s) -> o (c,s)) + -> StateT s m a -> StateT s n b -> StateT s o c+mapStateT2 f m1 m2 = StateT $ \s -> f (runStateT m1 s) (runStateT m2 s)++liftAndSkipStateT f m = StateT $ \s -> let a = evalStateT m s+ in do r <- f a+ return (r,s)++instance MonadAdvSTM m => MonadAdvSTM (StateT s m) where onCommit = lift . onCommit onRetry = lift . onRetry - orElse = mapReaderT2 orElse+ orElse = mapStateT2 orElse retry = lift retry check = lift . check - alwaysSucceeds = mapReaderT alwaysSucceeds-- always = mapReaderT always--- catchSTM m h = ReaderT (\r -> catchSTM (runReaderT m r) (\e -> runReaderT (h e) r))+ -- Note: The state modifications of the invariant action+ -- are thrown away!+ alwaysSucceeds = liftAndSkipStateT alwaysSucceeds + always = liftAndSkipStateT always+ + catchSTM m h = StateT (\r -> catchSTM (runStateT m r) (\e -> runStateT (h e) r)) liftAdv = lift . liftAdv @@ -145,30 +161,43 @@ newTVar = lift . newTVar +-------------------------------------------------------------------------------- -mapStateT2 :: (m (a, s) -> n (b, s) -> o (c,s)) -> StateT s m a -> StateT s n b -> StateT s o c-mapStateT2 f m1 m2 = StateT $ \s -> f (runStateT m1 s) (runStateT m2 s)+mapWriterT2 :: (m (a, w) -> n (b, w) -> o (c,w)) + -> WriterT w m a -> WriterT w n b -> WriterT w o c+mapWriterT2 f m1 m2 = WriterT $ f (runWriterT m1) (runWriterT m2)+-- mapWriterT2 f m1 m2 = liftM f m1 `ap` m2 -liftStateT f m = StateT $ \s -> let a = evalStateT m s- in do r <- f a- return (r,s)+evalWriterT :: Monad m => WriterT w m a -> m a+evalWriterT m = do+ (a,_) <- runWriterT m+ return a -instance MonadAdvSTM m => MonadAdvSTM (StateT s m) where+liftAndSkipWriterT :: (Monad m,Monoid w)+ => (m a -> m b)+ -> WriterT w m a -> WriterT w m b+liftAndSkipWriterT f m = WriterT $ + let a = evalWriterT m+ in do r <- f a+ return (r,mempty)++instance (MonadAdvSTM m, Monoid w) => MonadAdvSTM (WriterT w m) where onCommit = lift . onCommit onRetry = lift . onRetry - orElse = mapStateT2 orElse+ orElse = mapWriterT2 orElse retry = lift retry check = lift . check - alwaysSucceeds = liftStateT alwaysSucceeds -- always = liftStateT always+ -- Note: The writer-log modifications of the invariant action+ -- are thrown away!+ alwaysSucceeds = liftAndSkipWriterT alwaysSucceeds + always = liftAndSkipWriterT always - catchSTM m h = StateT (\r -> catchSTM (runStateT m r) (\e -> runStateT (h e) r))+ catchSTM m h = WriterT (catchSTM (runWriterT m) (\e -> runWriterT (h e))) liftAdv = lift . liftAdv @@ -178,32 +207,26 @@ newTVar = lift . newTVar ---- mapWriterT2 :: (m (a, w) -> n (b, w) -> o (c,w')) -> WriterT w m a -> WriterT w n b -> WriterT w' o c--- mapWriterT2 f m1 m2 = WriterT $ \s -> f (runWriterT m1 s) (runWriterT m2 s)+-------------------------------------------------------------------------------- -{-- - TODO: -liftWriterT f m = WriterT $ \s -> let a = runWriterT m s- in do r <- f a- return (r,s)+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, Monoid w) => MonadAdvSTM (WriterT w m) where+instance MonadAdvSTM m => MonadAdvSTM (ReaderT r m) where onCommit = lift . onCommit onRetry = lift . onRetry --- orElse = mapWriterT2 orElse+ orElse = mapReaderT2 orElse retry = lift retry check = lift . check --- alwaysSucceeds = mapWriterT alwaysSucceeds + alwaysSucceeds = mapReaderT alwaysSucceeds+ always = mapReaderT always --- always = mapWriterT always- - catchSTM m h = WriterT (\r -> catchSTM (runWriterT m r) (\e -> runWriterT (h e) r))+ catchSTM m h = ReaderT (\r -> catchSTM (runReaderT m r) (\e -> runReaderT (h e) r)) liftAdv = lift . liftAdv @@ -212,4 +235,6 @@ writeTVar tvar = lift . writeTVar tvar newTVar = lift . newTVar --}+++--------------------------------------------------------------------------------
stm-io-hooks.cabal view
@@ -19,11 +19,11 @@ Category: Concurrency Author: Peter Robinson 2009, Chris Kuklewicz 2006-Maintainer: Peter Robinson <thaldyron@gmail.com>+Maintainer: Peter Robinson <robinson@ecs.tuwien.ac.at> License: BSD3 License-file: LICENSE Homepage: http://darcs.monoid.at/stm-io-hooks-Version: 0.3.0+Version: 0.4.2 Build-type: Simple Cabal-Version: >= 1.2.3@@ -54,5 +54,6 @@ ,DeriveDataTypeable ,RankNTypes ,ExistentialQuantification+ ,UndecidableInstances