I was inspired by Simon's post to kludge up a working prototype that does what is discussed: Simon Peyton-Jones wrote:
| The basic idea is to provide a way for a transaction to call into transaction-aware libraries. The libraries | can register callbacks for if the transaction commits (to actually do any "O") and for if the transaction | aborts (to re-buffer any "I" that the transaction has consumed). In addition, a library providing access | to another transactional abstraction (e.g. a database supporting transactions) can perform a 2-phase | commit that means that the memory transaction and database transaction either both commit or both | abort.
Yes, I have toyed with extending GHC's implementation of STM to support
onCommit :: IO a -> STM ()
The idea is that onCommit would queue up an IO action to be performed when the transaction commits, but without any atomicity guarantee. If the transaction retries, the action is discarded. Now you could say
I have also toyed with adding
retryWith :: IO a -> STM ()
The idea here is that the transction is undone (i.e. just like the 'retry' combinator), then the specified action is performed, and then the transaction is retried. Again no atomicity guarantee. If there's an orElse involved, both actions would get done.
It would also make it possible to count how many retries happened: atomic (<transaction> `orElse` retryWith <increment retry counter>)
I have not implemented either of these, but I think they'd be cool.
Simon
The prototype is: {- November 24th, 2006 Demonstration Code by Chris Kuklewicz <haskell@list.mightyreason.com> Usual 3 clause BSD Licence Copyright 2006 This is inspired by a post by Simon Peyton-Jones on the haskell-cafe mailing list, in which the type and semantics of onCommit and withRetry were put forth. The semantics of printing the contents of the TVar "v" created in test via retryWith may or may not be well defined. With GHC 6.6 I get *AdvSTM> main "hello world" "retryWith Start" ("retryWith v",7) "Flipped choice to True to avoid infinite loop" "onCommit Start" ("onCommit v",42) ("result","foo") "bye world" Aside from that I think the unsafeIOToSTM is not really unsafe here since it writes to privately created and maintained variables. Since the implementation is hidden it could be changed from ReaderT to some other scheme. Once could also use MonadBase from http://haskell.org/haskellwiki/New_monads/MonadBase to help with the lifting, but this has been commented out below. TODO: figure out semantics of catchAdv. At least it compiles... -} module AdvSTM(MonadAdvSTM(..),AdvSTM,retryWith) where -- import MonadBase import Control.Exception(Exception) import Control.Monad(MonadPlus(..),liftM) import Control.Monad.Reader(MonadReader(..),ReaderT,runReaderT,lift,asks) import Control.Concurrent.STM(STM,orElse,retry,catchSTM,atomically) import Control.Concurrent.STM.TVar(TVar,newTVarIO,newTVar,readTVar,writeTVar) import GHC.Conc(unsafeIOToSTM) import Data.IORef(IORef,newIORef,readIORef,writeIORef,modifyIORef) import Data.Typeable(Typeable) import Data.Generics(Data) class MonadAdvSTM m where onCommit :: IO a -> m () onRetry :: IO a -> m () orElseAdv :: m a -> m a -> m a retryAdv :: m a atomicAdv :: m a -> IO a catchAdv :: m a -> (Exception -> m a) -> m a liftAdv :: STM a -> m a -- Export type but not constructor! newtype AdvSTM a = AdvSTM (ReaderT (CommitVar,RetryVar) STM a) deriving (Functor,Monad,MonadPlus,Typeable) type CommitVar = TVar ([IO ()]->[IO ()]) type RetryVar = IORef ([IO ()]->[IO ()]) {- Since lifting retry and `orElse` gives the semantics Simon wants, use deriving MonadPlus instead instance MonadPlus AdvSTM where mzero = retryAdv mplus = orElseAdv -} -- instance MonadBase STM AdvSTM where liftBase = AdvSTM . lift retryWith :: IO a -> AdvSTM b retryWith io = onRetry io >> retryAdv instance MonadAdvSTM AdvSTM where onCommit io = do cv <- AdvSTM $ asks fst old <- liftAdv $ readTVar cv liftAdv $ writeTVar cv (old . ((io >> return ()):)) onRetry io = do rv <- AdvSTM $ asks snd liftAdv $ unsafeIOToSTM $ modifyIORef rv (\ old -> old . ((io >> return ()):) ) {- orElseAdv (AdvSTM a) (AdvSTM b) = {- If a retries then its onRetry commands are kept on the list of actions to do if the whole command fails. It would be possible to save the "rv" and use unsafeIOToSTM to implement a different policy here -} AdvSTM $ do env <- ask lift $ (runReaderT a env) `orElse` (runReaderT b env) -} orElseAdv = mplus retryAdv = liftAdv retry -- the same as retryAdv = mzero atomicAdv = runAdvSTM catchAdv (AdvSTM action) handler = let h env error = let (AdvSTM cleanup) = handler error in runReaderT cleanup env in AdvSTM $ do env <- ask lift $ catchSTM (runReaderT action env) (h env) liftAdv = AdvSTM . lift -- This replaces "atomically" runAdvSTM :: AdvSTM a -> IO a runAdvSTM (AdvSTM action) = do cv <- newTVarIO id rv <- newIORef id let wrappedAction = (runReaderT (liftM Just action) (cv,rv)) `orElse` (return Nothing) loop = do result <- atomically $ wrappedAction case result of Just answer -> do cFun <- atomically (readTVar cv) sequence_ (cFun []) return answer Nothing -> do rFun <- readIORef rv writeIORef rv id -- must reset the list sequence_ (rFun []) loop loop -- Example code using the above: test :: TVar Bool -> AdvSTM String test todo = do onCommit (print "onCommit Start") onRetry (print "onRetry Start") v <- liftAdv $ newTVar 7 liftAdv $ writeTVar v 42 onCommit (atomically (readTVar v) >>= \x->print ("onCommit v",x)) onRetry (atomically (readTVar v) >>= \x->print ("onRetry v",x)) choice <- liftAdv $ readTVar todo case choice of True -> return "foo" False -> retryWith $ do atomically (writeTVar todo True) print "Flipped choice to True to avoid infinite loop" -- Example similar to Simon's suggested example: countRetries :: IORef Int -> AdvSTM a -> AdvSTM a countRetries ioref action = let incr = do old <- readIORef ioref writeIORef ioref $! (succ old) in action `orElseAdv` (retryWith incr) -- Load this file in GHCI and execute main to run the test: main = do print "hello world" todo <- newTVarIO False counter <- newIORef 0 result <- runAdvSTM (test todo) print ("result",result) print "bye world"