module Control.Object.Instance (
Instance(..)
, new
, newSettle
, newSTM
, invokeOn
, invokeOnSTM
, (.-)
, (..-)
, snapshot
) where
import Control.Concurrent.STM.TMVar
import Control.Monad.STM
import Control.Object.Object
import Control.Monad.IO.Class
import Control.Monad.STM.Class
import Control.Monad
import Control.Monad.Catch (MonadMask, bracketOnError)
data Instance f g where
InstRef :: (forall x. e x -> f x) -> (forall x. g x -> h x) -> TMVar (Object f g) -> Instance e h
instance HProfunctor Instance where
f ^>>@ InstRef l r v = InstRef (l . f) r v
InstRef l r v @>>^ f = InstRef l (f . r) v
invokeOn :: (MonadIO m, MonadMask m)
=> (forall x. g x -> m x) -> Instance f g -> f a -> m a
invokeOn m (InstRef t l v) f = bracketOnError
(liftIO $ atomically $ takeTMVar v)
(\obj -> liftIO $ atomically $ do
_ <- tryTakeTMVar v
putTMVar v obj)
(\obj -> do
(a, obj') <- m $ l $ runObject obj (t f)
liftIO $ atomically $ putTMVar v obj'
return a)
invokeOnSTM :: (forall x. g x -> STM x) -> Instance f g -> f a -> STM a
invokeOnSTM m (InstRef t l v) f = do
obj <- takeTMVar v
(a, obj') <- m $ l $ runObject obj (t f)
putTMVar v obj'
return a
(..-) :: MonadSTM m => Instance f STM -> f a -> m a
(..-) i = liftSTM . invokeOnSTM id i
infixr 3 ..-
(.-) :: (MonadIO m, MonadMask m) => Instance f m -> f a -> m a
(.-) = invokeOn id
infixr 3 .-
snapshot :: (MonadSTM m, Functor g) => Instance f g -> m (Object f g)
snapshot (InstRef f g v) = liftSTM $ go `fmap` takeTMVar v
where go (Object m) = Object $ fmap (fmap go) . g . m . f
new :: MonadIO m => Object f g -> m (Instance f g)
new = liftIO . liftM (InstRef id id) . newTMVarIO
newSettle :: MonadIO m => Object f m -> m (Instance f m)
newSettle = new
newSTM :: MonadSTM m => Object f g -> m (Instance f g)
newSTM = liftSTM . liftM (InstRef id id) . newTMVar