----------------------------------------------------------------------------- -- | -- Module : Control.Monad.AdvSTM.Class -- Copyright : (c) HaskellWiki 2006-2007, Peter Robinson 2008 -- License : BSD3 -- -- Maintainer : Peter Robinson -- Stability : experimental -- Portability : non-portable (requires STM) -- -- Provides the type class MonadAdvSTM -- Parts of this implementation were taken from the HaskellWiki Page of -- MonadAdvSTM (see package description). ----------------------------------------------------------------------------- module Control.Monad.AdvSTM.Class( MonadAdvSTM(..), TVar(TVar), valueTVar, onCommitLock, currentTid ) where import Control.Exception(Exception) 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.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.AdvSTM.Def(AdvSTM) import Control.Concurrent( ThreadId ) --import GHC.Conc( unsafeIOToSTM ) -- import {-# SOURCE #-} Control.Concurrent.AdvSTM.TVar import Data.Monoid data TVar a = TVar { valueTVar :: OldTVar.TVar a , onCommitLock :: OldTMVar.TMVar () , currentTid :: OldTVar.TVar (Maybe ThreadId) } -- | A type class for extended-STM monads. For a concrete instantiation see -- 'AdvSTM' class Monad m => MonadAdvSTM m where -- | Takes an IO action that will be executed /iff/ the transaction commits. -- -- * When a TVar was modified in a transaction and this transaction commits, -- this update remains invisible to other threads until the corresponding -- onCommit action was run. -- -- * If the onCommit action throws an exception, the original value of -- the TVars will be restored. -- -- * Accessing a modified TVar within the onCommit action will cause a -- Deadlock exception to be thrown. -- -- As a general rule, 'onCommit' should -- only be used for \"real\" (i.e. without atomic blocks) IO actions and is certainly -- not the right place to fiddle with TVars. For example, if you wanted to -- write a TVar value to a file on commit, you could write: -- -- > tvar <- newTVarIO "bla" -- > atomically $ do -- > x <- readTVar tvar -- > onCommit (writeFile "myfile" x) -- -- onCommit :: IO () -> m () -- | Adds an IO action to the retry job-queue. If the transaction retries, -- 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 () -- | See 'S.orElse' orElse :: m a -> m a -> m a -- | Runs any IO actions added by 'onRetry' and then retries the -- transaction. retry :: m a -- | See 'S.check' check :: Bool -> m () -- | See 'S.alwaysSucceeds' alwaysSucceeds :: m a -> m () -- | 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 -- | Reads a value from a TVar. Blocks until the IO onCommit action(s) of -- the corresponding transaction are complete. -- See 'onCommit' for a more detailed description of this behaviour. readTVar :: TVar a -> m a -- | Writes a value to a TVar. Blocks until the onCommit IO-action(s) are -- complete. See 'onCommit' for details. writeTVar :: TVar a -> a -> m () -- | See 'OldTVar.newTVar' newTVar :: a -> m (TVar a) -- newTVarIO :: a -> IO (TVar a) 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 onCommit = lift . onCommit onRetry = lift . onRetry orElse = mapReaderT2 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)) liftAdv = lift . liftAdv readTVar = lift . readTVar writeTVar tvar = lift . writeTVar tvar 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) liftStateT 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 = mapStateT2 orElse retry = lift retry check = lift . check alwaysSucceeds = liftStateT alwaysSucceeds always = liftStateT always catchSTM m h = StateT (\r -> catchSTM (runStateT m r) (\e -> runStateT (h e) r)) liftAdv = lift . liftAdv readTVar = lift . readTVar writeTVar tvar = lift . writeTVar tvar 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) instance (MonadAdvSTM m, Monoid w) => MonadAdvSTM (WriterT w m) where onCommit = lift . onCommit onRetry = lift . onRetry -- orElse = mapWriterT2 orElse retry = lift retry check = lift . check -- alwaysSucceeds = mapWriterT alwaysSucceeds -- always = mapWriterT always catchSTM m h = WriterT (\r -> catchSTM (runWriterT m r) (\e -> runWriterT (h e) r)) liftAdv = lift . liftAdv readTVar = lift . readTVar writeTVar tvar = lift . writeTVar tvar newTVar = lift . newTVar -}