Alright, I have tested it now. I still feel funny about most of the names I chose for the types and functions, and it's still very ugly, but the code appears to work correctly. In this version I have also added "retry" and "orElse" functions so that it can feel more like the STM monad. I think the biggest downside to this monad is the potential confusion about whether to use "could" or "must," but I have a feeling that better naming choices would reduce the ambiguity. Thoughts?
module CachedSTM where
import Control.Applicative import Control.Concurrent.STM as S import Control.Monad
data CachedSTM a = CSTM { getMust :: STM (), getCould :: STM a }
instance Functor CachedSTM where f `fmap` (CSTM m s) = CSTM m $ f <$> s
joinCSTM :: CachedSTM (CachedSTM a) -> CachedSTM a joinCSTM cstm = CSTM m s where m = do cstm' <- getCould cstm getMust cstm' `S.orElse` return () getMust cstm `S.orElse` return () s = getCould =<< getCould cstm
instance Applicative CachedSTM where pure = return (<*>) = ap
instance Monad CachedSTM where return = CSTM (return ()) . return x >>= f = joinCSTM $ f <$> x
maybeAtomicallyC :: CachedSTM a -> IO (Maybe a) maybeAtomicallyC cstm = atomically $ do getMust cstm liftM Just (getCould cstm) `S.orElse` return Nothing
could :: STM a -> CachedSTM a could stm = CSTM (return ()) stm
must :: STM () -> CachedSTM () must stm = CSTM (stm `S.orElse` return ()) $ return ()
retry :: CachedSTM a retry = could S.retry
orElse :: CachedSTM a -> CachedSTM a -> CachedSTM a orElse a b = do must $ getMust a temp <- could newEmptyTMVar must $ (getCould a >>= putTMVar temp) `S.orElse` getMust b could $ takeTMVar temp `S.orElse` getCould b
I don't think the IVar code has changed (no version control for this), but here it is again for quick reference:
module IVal where
import CachedSTM import Control.Applicative import Control.Concurrent.STM import Control.Monad import System.IO.Unsafe
newtype IVal a = IVal (TVar (Either (CachedSTM a) a))
newIVal :: CachedSTM a -> CachedSTM (IVal a) newIVal = fmap IVal . could . newTVar . Left
newIValIO :: CachedSTM a -> IO (IVal a) newIValIO = fmap IVal . newTVarIO . Left
cached :: CachedSTM a -> IVal a cached = unsafePerformIO . newIValIO
force :: IVal a -> CachedSTM a force (IVal tv) = could (readTVar tv) >>= either compute return where compute wait = do x <- wait must . writeTVar tv $ Right x return x
instance Functor IVal where f `fmap` x = cached $ f <$> force x
instance Applicative IVal where pure = return (<*>) = ap
instance Monad IVal where return = cached . return x >>= f = cached (force x >>= force . f)
- Jake