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.Concurrent( ThreadId )
import Data.Monoid
data TVar a = TVar
{ valueTVar :: OldTVar.TVar a
, onCommitLock :: OldTMVar.TMVar ()
, currentTid :: OldTVar.TVar (Maybe ThreadId)
}
class Monad m => MonadAdvSTM m where
onCommit :: IO () -> m ()
unsafeRetryWith :: IO () -> m b
orElse :: m a -> m a -> m a
retry :: m a
check :: Bool -> m ()
alwaysSucceeds :: m a -> m ()
always :: m Bool -> m ()
catchSTM :: Exception e => m a -> (e -> m a) -> m a
liftAdv :: S.STM a -> m a
readTVar :: TVar a -> m a
writeTVar :: TVar a -> a -> m ()
readTVarAsync :: TVar a -> m a
writeTVarAsync :: TVar a -> a -> m ()
newTVar :: a -> m (TVar a)
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
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
readTVarAsync = lift . readTVarAsync
writeTVarAsync tvar = lift . writeTVarAsync 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)
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
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
readTVarAsync = lift . readTVarAsync
writeTVarAsync tvar = lift . writeTVarAsync 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
writeTVarAsync tvar = lift . writeTVarAsync tvar
readTVarAsync = lift . readTVarAsync
writeTVar tvar = lift . writeTVar tvar
readTVar = lift . readTVar
newTVar = lift . newTVar