----------------------------------------------------------------------------- -- | -- Module : Control.Monad.AdvSTM.Class -- Copyright : Peter Robinson 2008, HaskellWiki 2006-2007 -- License : BSD3 -- -- Maintainer : Peter Robinson <robinson@ecs.tuwien.ac.at> -- 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(..), handleSTM, TVar(TVar), valueTVar, onCommitLock, currentTid) where 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,ap) import Control.Monad.Trans(lift) 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 ) -- 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 () -- | Retries the transaction and uses 'unsafeIOToSTM' to fork off a -- thread that runs the given IO action. Since a transaction might be rerun -- several times by the runtime system, it is your responsibility to -- ensure that the IO-action is idempotent and releases all acquired locks. unsafeRetryWith :: IO () -> m b -- | See 'S.orElse' orElse :: m a -> m a -> m a -- | See 'S.retry' retry :: m a -- | See 'S.check' check :: Bool -> m () -- | See 'S.alwaysSucceeds' alwaysSucceeds :: m a -> m () -- | See 'S.always' always :: m Bool -> m () -- | 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) -- -- 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 -------------------------------------------------------------------------------- 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 unsafeRetryWith = lift . unsafeRetryWith orElse = mapStateT2 orElse retry = lift retry check = lift . check -- 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 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 $ f (runWriterT m1) (runWriterT m2) -- mapWriterT2 f m1 m2 = liftM f m1 `ap` m2 evalWriterT :: Monad m => WriterT w m a -> m a evalWriterT m = do (a,_) <- runWriterT m return a 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 unsafeRetryWith = lift . unsafeRetryWith orElse = mapWriterT2 orElse retry = lift retry check = lift . check -- Note: The writer-log modifications of the invariant action -- are thrown away! alwaysSucceeds = liftAndSkipWriterT alwaysSucceeds always = liftAndSkipWriterT always catchSTM m h = WriterT (catchSTM (runWriterT m) (\e -> runWriterT (h e))) liftAdv = lift . liftAdv readTVar = lift . readTVar writeTVar tvar = lift . writeTVar tvar newTVar = lift . newTVar -------------------------------------------------------------------------------- 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 unsafeRetryWith = lift . unsafeRetryWith 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 --------------------------------------------------------------------------------