module Control.Concurrent.MState
(
MState
, module Control.Monad.State.Class
, runMState
, evalMState
, execMState
, mapMState
, modifyM
, modifyM_
, forkM
, forkM_
, killMState
) where
import Prelude hiding (catch)
import Control.Applicative
import Control.Monad.State.Class
import Control.Monad.Cont
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad.IO.Peel
import Control.Exception.Peel
import Control.Monad.Trans.Peel
newtype MState t m a = MState { runMState' :: (TVar t, TVar [(ThreadId, TMVar ())]) -> m a }
waitForTermination :: MonadIO m
=> TVar [(ThreadId, TMVar ())]
-> m ()
waitForTermination = liftIO . atomically . (mapM_ (takeTMVar . snd) <=< readTVar)
runMState :: MonadPeelIO m
=> MState t m a
-> t
-> m (a,t)
runMState m t = do
(a, Just t') <- runAndWaitMaybe True m t
return (a, t')
runAndWaitMaybe :: MonadPeelIO m
=> Bool
-> MState t m a
-> t
-> m (a, Maybe t)
runAndWaitMaybe b m t = do
myI <- liftIO myThreadId
myM <- liftIO newEmptyTMVarIO
ref <- liftIO $ newTVarIO t
c <- liftIO $ newTVarIO [(myI, myM)]
a <- runMState' m (ref, c) `finally` liftIO (atomically $ putTMVar myM ())
if b then do
waitForTermination c
t' <- liftIO $ readTVarIO ref
return (a, Just t')
else
return (a, Nothing)
evalMState :: MonadPeelIO m
=> Bool
-> MState t m a
-> t
-> m a
evalMState b m t = runAndWaitMaybe b m t >>= return . fst
execMState :: MonadPeelIO m
=> MState t m a
-> t
-> m t
execMState m t = runMState m t >>= return . snd
mapMState :: (MonadIO m, MonadIO n)
=> (m (a,t) -> n (b,t))
-> MState t m a
-> MState t n b
mapMState f m = MState $ \s@(r,_) -> do
~(b,v') <- f $ do
a <- runMState' m s
v <- liftIO $ readTVarIO r
return (a,v)
liftIO . atomically $ writeTVar r v'
return b
modifyM :: MonadIO m => (t -> (a,t)) -> MState t m a
modifyM f = MState $ \(t,_) ->
liftIO . atomically $ do
v <- readTVar t
let (a,v') = f v
writeTVar t v'
return a
modifyM_ :: MonadIO m => (t -> t) -> MState t m ()
modifyM_ f = modifyM (\t -> ((), f t))
fork :: MonadPeelIO m => m () -> m ThreadId
fork m = do
k <- peelIO
liftIO . forkIO $ k m >> return ()
forkM :: MonadPeelIO m
=> MState t m ()
-> MState t m ThreadId
forkM m = MState $ \s@(_,c) -> do
w <- liftIO newEmptyTMVarIO
tid <- fork $
runMState' m s `finally` liftIO (atomically $ putTMVar w ())
liftIO . atomically $ do
r <- readTVar c
writeTVar c ((tid,w):r)
return tid
forkM_ :: MonadPeelIO m
=> MState t m ()
-> MState t m ()
forkM_ m = do
_ <- forkM m
return ()
killMState :: MonadPeelIO m => MState t m ()
killMState = MState $ \(_,tv) -> do
tms <- liftIO $ readTVarIO tv
_ <- liftIO . forkIO $
mapM_ (killThread . fst) tms
return ()
instance (Monad m) => Monad (MState t m) where
return a = MState $ \_ -> return a
m >>= k = MState $ \t -> do
a <- runMState' m t
runMState' (k a) t
fail str = MState $ \_ -> fail str
instance (Functor f) => Functor (MState t f) where
fmap f m = MState $ \t -> fmap f (runMState' m t)
instance (Applicative m, Monad m) => Applicative (MState t m) where
pure = return
(<*>) = ap
instance (MonadPlus m) => MonadPlus (MState t m) where
mzero = MState $ \_ -> mzero
m `mplus` n = MState $ \t -> runMState' m t `mplus` runMState' n t
instance (MonadIO m) => MonadState t (MState t m) where
get = MState $ \(r,_) -> liftIO $ readTVarIO r
put val = MState $ \(r,_) -> liftIO . atomically $ writeTVar r val
instance (MonadFix m) => MonadFix (MState t m) where
mfix f = MState $ \s -> mfix $ \a -> runMState' (f a) s
instance MonadTrans (MState t) where
lift m = MState $ \_ -> m
instance (MonadIO m) => MonadIO (MState t m) where
liftIO = lift . liftIO
instance (MonadCont m) => MonadCont (MState t m) where
callCC f = MState $ \s ->
callCC $ \c ->
runMState' (f (\a -> MState $ \_ -> c a)) s
instance (MonadError e m) => MonadError e (MState t m) where
throwError = lift . throwError
m `catchError` h = MState $ \s ->
runMState' m s `catchError` \e -> runMState' (h e) s
instance (MonadReader r m) => MonadReader r (MState t m) where
ask = lift ask
local f m = MState $ \s -> local f (runMState' m s)
instance (MonadWriter w m) => MonadWriter w (MState t m) where
tell = lift . tell
listen m = MState $ listen . runMState' m
pass m = MState $ pass . runMState' m
instance MonadTransPeel (MState t) where
peel = MState $ \t -> return $ \m -> do
a <- runMState' m t
return $ return a
instance MonadPeelIO m => MonadPeelIO (MState t m) where
peelIO = liftPeel peelIO