module Control.Object.Instance 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 :: TMVar (Object f g) -> Instance f g
InstLmap :: (forall x. f x -> g x) -> Instance g h -> Instance f h
InstRmap :: Instance f g -> (forall x. g x -> h x) -> Instance f h
instance HProfunctor Instance where
(^>>@) = InstLmap
(@>>^) = InstRmap
invokeOn :: (MonadIO m, MonadMask m)
=> (forall x. g x -> m x) -> Instance f g -> f a -> m a
invokeOn m (InstRef v) f = bracketOnError
(liftIO $ atomically $ takeTMVar v)
(\obj -> liftIO $ atomically $ do
_ <- tryTakeTMVar v
putTMVar v obj)
(\obj -> do
(a, obj') <- m (runObject obj f)
liftIO $ atomically $ putTMVar v obj'
return a)
invokeOn m (InstLmap t i) f = invokeOn m i (t f)
invokeOn m (InstRmap i t) f = invokeOn (m . t) i f
invokeOnSTM :: (forall x. g x -> STM x) -> Instance f g -> f a -> STM a
invokeOnSTM m (InstRef v) f = do
obj <- takeTMVar v
(a, obj') <- m (runObject obj f)
putTMVar v obj'
return a
invokeOnSTM m (InstLmap t i) f = invokeOnSTM m i (t f)
invokeOnSTM m (InstRmap i t) f = invokeOnSTM (m . t) i f
(..-) :: 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 .-
new :: MonadIO m => Object f g -> m (Instance f g)
new = liftIO . atomically . newSTM
newSettle :: MonadIO m => Object f m -> m (Instance f m)
newSettle = new
newSTM :: Object f g -> STM (Instance f g)
newSTM = liftM InstRef . newTMVar