module Control.Monad.State.Concurrent.Lazy (
module Control.Monad.State,
StateC,
runStateC, evalStateC, execStateC,
runStatesC, evalStatesC, execStatesC,
liftCallCC, liftCatch, liftListen, liftPass
) where
import Control.Applicative
import Control.Concurrent.Lifted.Fork
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.Exception (throwIO)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.State
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706
import Prelude hiding (catch)
#endif
newtype StateC s m a = StateC { _runStateC :: TVar s -> m (a, TVar s) }
instance MonadTrans (StateC s) where
lift m = StateC $ \s -> do
a <- m
return (a, s)
instance (Functor m, MonadIO m) => Functor (StateC s m) where
fmap f m = StateC $ \s ->
fmap (\ ~(a, s') -> (f a, s')) $ _runStateC m s
instance (Functor m, MonadIO m) => Applicative (StateC s m) where
pure = return
(<*>) = ap
instance (MonadIO m, Functor m, MonadPlus m) => Alternative (StateC s m) where
empty = mzero
(<|>) = mplus
instance (MonadPlus m, MonadIO m) => MonadPlus (StateC s m) where
mzero = StateC $ const mzero
m `mplus` n = StateC $ \s -> _runStateC m s `mplus` _runStateC n s
instance MonadIO m => Monad (StateC s m) where
return a = StateC $ \s -> return (a, s)
m >>= k = StateC $ \s -> do
~(a, s') <- _runStateC m s
_runStateC (k a) s'
instance (Functor m, MonadIO m) => MonadState s (StateC s m) where
get = StateC $ \tv -> do
s <- liftIO $ readTVarIO tv
return (s, tv)
state f = StateC $ \tv -> do
newval <- liftIO . atomically $ do
old <- readTVar tv
let ~(a, s) = f old
_ <- swapTVar tv s
return a
return (newval, tv)
instance (MonadIO m, MonadFix m) => MonadFix (StateC s m) where
mfix f = StateC $ \s -> mfix $ \ ~(a, _) -> _runStateC (f a) s
instance MonadIO m => MonadIO (StateC s m) where
liftIO i = StateC $ \s -> do
a <- liftIO i
return (a, s)
instance (MonadIO m, MonadCatch m) => MonadCatch (StateC s m) where
throwM = liftIO . throwIO
catch = liftCatch catch
mask a = StateC $ \tv -> mask $ \u -> _runStateC (a $ q u) tv where
q u (StateC f) = StateC (u . f)
uninterruptibleMask a =
StateC $ \tv -> uninterruptibleMask $ \u -> _runStateC (a $ q u) tv where
q u (StateC f) = StateC (u . f)
instance MonadFork m => MonadFork (StateC s m) where
fork = liftFork fork
forkOn i = liftFork (forkOn i)
forkOS = liftFork forkOS
liftFork :: Monad m => (m () -> m a) -> StateC t m () -> StateC t m a
liftFork f (StateC m) = StateC $ \tv -> do
tid <- f . voidM $ m tv
return (tid, tv)
where voidM = (>> return ())
runStateC :: MonadIO m
=> StateC s m a
-> TVar s
-> m (a, s)
runStateC m s = do
~(a, b) <- _runStateC m s
r <- liftIO $ readTVarIO b
return (a, r)
evalStateC :: MonadIO m
=> StateC s m a
-> TVar s
-> m a
evalStateC m s = liftM fst $ runStateC m s
execStateC :: MonadIO m
=> StateC s m a
-> TVar s
-> m s
execStateC m s = liftM snd $ runStateC m s
liftCallCC :: ((((a, TVar s) -> m (b, TVar s)) -> m (a, TVar s)) -> m (a, TVar s)) ->
((a -> StateC s m b) -> StateC s m a) -> StateC s m a
liftCallCC callCC f = StateC $ \tv ->
callCC $ \c ->
_runStateC (f (\a -> StateC $ \_ -> c (a, tv))) tv
liftCatch :: (m (a, TVar s) -> (e -> m (a, TVar s)) -> m (a, TVar s)) ->
StateC s m a -> (e -> StateC s m a) -> StateC s m a
liftCatch catchError m h =
StateC $ \s -> _runStateC m s `catchError` \e -> _runStateC (h e) s
liftListen :: Monad m =>
(m (a, TVar s) -> m ((a, TVar s), w)) -> StateC s m a -> StateC s m (a,w)
liftListen listen m = StateC $ \tv -> do
~((a, s'), w) <- listen (_runStateC m tv)
return ((a, w), s')
liftPass :: Monad m =>
(m ((a, TVar s), b) -> m (a, TVar s)) -> StateC s m (a, b) -> StateC s m a
liftPass pass m = StateC $ \tv -> pass $ do
~((a, f), s') <- _runStateC m tv
return ((a, s'), f)
runStatesC :: MonadFork m
=> [StateC s m a]
-> s
-> m ([a], s)
runStatesC ms s = do
v <- liftIO $ newTVarIO s
mvs <- mapM (const (liftIO newEmptyMVar)) ms
forM_ (zip mvs ms) $ \(mv, operation) -> fork $ do
res <- evalStateC operation v
liftIO $ putMVar mv res
items <- forM mvs (liftIO . takeMVar)
end <- liftIO $ readTVarIO v
return (items, end)
evalStatesC :: MonadFork m
=> [StateC s m a]
-> s
-> m [a]
evalStatesC ms s = liftM fst $ runStatesC ms s
execStatesC :: MonadFork m
=> [StateC s m a]
-> s
-> m s
execStatesC ms s = liftM snd $ runStatesC ms s