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