stm-io-hooks-0.3.0: Control/Monad/AdvSTM/Class.hs
-----------------------------------------------------------------------------
-- |
-- Module : Control.Monad.AdvSTM.Class
-- Copyright : (c) HaskellWiki 2006-2007, Peter Robinson 2008
-- 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(..), 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
-}