module Control.Monad.Conc.Class
( MonadConc(..)
, spawn
, forkFinally
, killThread
) where
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (MVar, readMVar, newEmptyMVar, putMVar, tryPutMVar, takeMVar, tryTakeMVar)
import Control.Exception (Exception, AsyncException(ThreadKilled), SomeException)
import Control.Monad (liftM)
import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask)
import Control.Monad.Reader (ReaderT(..), runReaderT)
import Control.Monad.STM (STM)
import Control.Monad.STM.Class (MonadSTM, CTVar)
import Control.Monad.Trans (lift)
import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef)
import qualified Control.Concurrent as C
import qualified Control.Monad.Catch as Ca
import qualified Control.Monad.RWS.Lazy as RL
import qualified Control.Monad.RWS.Strict as RS
import qualified Control.Monad.STM as S
import qualified Control.Monad.State.Lazy as SL
import qualified Control.Monad.State.Strict as SS
import qualified Control.Monad.Writer.Lazy as WL
import qualified Control.Monad.Writer.Strict as WS
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative)
import Data.Monoid (Monoid, mempty)
#endif
class ( Applicative m, Monad m
, MonadCatch m, MonadThrow m, MonadMask m
, MonadSTM (STMLike m)
, Eq (ThreadId m), Show (ThreadId m)) => MonadConc m where
type STMLike m :: * -> *
type CVar m :: * -> *
type CRef m :: * -> *
type ThreadId m :: *
fork :: m () -> m (ThreadId m)
forkWithUnmask :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
forkOn :: Int -> m () -> m (ThreadId m)
getNumCapabilities :: m Int
myThreadId :: m (ThreadId m)
newEmptyCVar :: m (CVar m a)
putCVar :: CVar m a -> a -> m ()
tryPutCVar :: CVar m a -> a -> m Bool
readCVar :: CVar m a -> m a
takeCVar :: CVar m a -> m a
tryTakeCVar :: CVar m a -> m (Maybe a)
newCRef :: a -> m (CRef m a)
readCRef :: CRef m a -> m a
modifyCRef :: CRef m a -> (a -> (a, b)) -> m b
writeCRef :: CRef m a -> a -> m ()
writeCRef r a = modifyCRef r $ const (a, ())
atomically :: STMLike m a -> m a
throw :: Exception e => e -> m a
throw = Ca.throwM
catch :: Exception e => m a -> (e -> m a) -> m a
catch = Ca.catch
throwTo :: Exception e => ThreadId m -> e -> m ()
mask :: ((forall a. m a -> m a) -> m b) -> m b
mask = Ca.mask
uninterruptibleMask :: ((forall a. m a -> m a) -> m b) -> m b
uninterruptibleMask = Ca.uninterruptibleMask
_concNoTest :: m a -> m a
_concNoTest = id
_concKnowsAbout :: Either (CVar m a) (CTVar (STMLike m) a) -> m ()
_concKnowsAbout _ = return ()
_concForgets :: Either (CVar m a) (CTVar (STMLike m) a) -> m ()
_concForgets _ = return ()
_concAllKnown :: m ()
_concAllKnown = return ()
instance MonadConc IO where
type STMLike IO = STM
type CVar IO = MVar
type CRef IO = IORef
type ThreadId IO = C.ThreadId
readCVar = readMVar
fork = forkIO
forkWithUnmask = C.forkIOWithUnmask
forkOn = C.forkOn
getNumCapabilities = C.getNumCapabilities
myThreadId = C.myThreadId
throwTo = C.throwTo
newEmptyCVar = newEmptyMVar
putCVar = putMVar
tryPutCVar = tryPutMVar
takeCVar = takeMVar
tryTakeCVar = tryTakeMVar
newCRef = newIORef
readCRef = readIORef
modifyCRef = atomicModifyIORef
atomically = S.atomically
spawn :: MonadConc m => m a -> m (CVar m a)
spawn ma = do
cvar <- newEmptyCVar
_ <- fork $ _concKnowsAbout (Left cvar) >> ma >>= putCVar cvar
return cvar
forkFinally :: MonadConc m => m a -> (Either SomeException a -> m ()) -> m (ThreadId m)
forkFinally action and_then =
mask $ \restore ->
fork $ Ca.try (restore action) >>= and_then
killThread :: MonadConc m => ThreadId m -> m ()
killThread tid = throwTo tid ThreadKilled
instance MonadConc m => MonadConc (ReaderT r m) where
type STMLike (ReaderT r m) = STMLike m
type CVar (ReaderT r m) = CVar m
type CRef (ReaderT r m) = CRef m
type ThreadId (ReaderT r m) = ThreadId m
fork = reader fork
forkOn i = reader (forkOn i)
forkWithUnmask ma = ReaderT $ \r -> forkWithUnmask (\f -> runReaderT (ma $ reader f) r)
_concNoTest = reader _concNoTest
getNumCapabilities = lift getNumCapabilities
myThreadId = lift myThreadId
throwTo t = lift . throwTo t
newEmptyCVar = lift newEmptyCVar
readCVar = lift . readCVar
putCVar v = lift . putCVar v
tryPutCVar v = lift . tryPutCVar v
takeCVar = lift . takeCVar
tryTakeCVar = lift . tryTakeCVar
newCRef = lift . newCRef
readCRef = lift . readCRef
modifyCRef r = lift . modifyCRef r
atomically = lift . atomically
_concKnowsAbout = lift . _concKnowsAbout
_concForgets = lift . _concForgets
_concAllKnown = lift _concAllKnown
reader :: Monad m => (m a -> m b) -> ReaderT r m a -> ReaderT r m b
reader f ma = ReaderT $ \r -> f (runReaderT ma r)
instance (MonadConc m, Monoid w) => MonadConc (WL.WriterT w m) where
type STMLike (WL.WriterT w m) = STMLike m
type CVar (WL.WriterT w m) = CVar m
type CRef (WL.WriterT w m) = CRef m
type ThreadId (WL.WriterT w m) = ThreadId m
fork = writerlazy fork
forkOn i = writerlazy (forkOn i)
forkWithUnmask ma = lift $ forkWithUnmask (\f -> fst `liftM` WL.runWriterT (ma $ writerlazy f))
_concNoTest = writerlazy _concNoTest
getNumCapabilities = lift getNumCapabilities
myThreadId = lift myThreadId
throwTo t = lift . throwTo t
newEmptyCVar = lift newEmptyCVar
readCVar = lift . readCVar
putCVar v = lift . putCVar v
tryPutCVar v = lift . tryPutCVar v
takeCVar = lift . takeCVar
tryTakeCVar = lift . tryTakeCVar
newCRef = lift . newCRef
readCRef = lift . readCRef
modifyCRef r = lift . modifyCRef r
atomically = lift . atomically
_concKnowsAbout = lift . _concKnowsAbout
_concForgets = lift . _concForgets
_concAllKnown = lift _concAllKnown
writerlazy :: (Monad m, Monoid w) => (m a -> m b) -> WL.WriterT w m a -> WL.WriterT w m b
writerlazy f ma = lift . f $ fst `liftM` WL.runWriterT ma
instance (MonadConc m, Monoid w) => MonadConc (WS.WriterT w m) where
type STMLike (WS.WriterT w m) = STMLike m
type CVar (WS.WriterT w m) = CVar m
type CRef (WS.WriterT w m) = CRef m
type ThreadId (WS.WriterT w m) = ThreadId m
fork = writerstrict fork
forkOn i = writerstrict (forkOn i)
forkWithUnmask ma = lift $ forkWithUnmask (\f -> fst `liftM` WS.runWriterT (ma $ writerstrict f))
_concNoTest = writerstrict _concNoTest
getNumCapabilities = lift getNumCapabilities
myThreadId = lift myThreadId
throwTo t = lift . throwTo t
newEmptyCVar = lift newEmptyCVar
readCVar = lift . readCVar
putCVar v = lift . putCVar v
tryPutCVar v = lift . tryPutCVar v
takeCVar = lift . takeCVar
tryTakeCVar = lift . tryTakeCVar
newCRef = lift . newCRef
readCRef = lift . readCRef
modifyCRef r = lift . modifyCRef r
atomically = lift . atomically
_concKnowsAbout = lift . _concKnowsAbout
_concForgets = lift . _concForgets
_concAllKnown = lift _concAllKnown
writerstrict :: (Monad m, Monoid w) => (m a -> m b) -> WS.WriterT w m a -> WS.WriterT w m b
writerstrict f ma = lift . f $ fst `liftM` WS.runWriterT ma
instance MonadConc m => MonadConc (SL.StateT s m) where
type STMLike (SL.StateT s m) = STMLike m
type CVar (SL.StateT s m) = CVar m
type CRef (SL.StateT s m) = CRef m
type ThreadId (SL.StateT s m) = ThreadId m
fork = statelazy fork
forkOn i = statelazy (forkOn i)
forkWithUnmask ma = SL.StateT $ \s -> (\a -> (a,s)) `liftM` forkWithUnmask (\f -> SL.evalStateT (ma $ statelazy f) s)
_concNoTest = statelazy _concNoTest
getNumCapabilities = lift getNumCapabilities
myThreadId = lift myThreadId
throwTo t = lift . throwTo t
newEmptyCVar = lift newEmptyCVar
readCVar = lift . readCVar
putCVar v = lift . putCVar v
tryPutCVar v = lift . tryPutCVar v
takeCVar = lift . takeCVar
tryTakeCVar = lift . tryTakeCVar
newCRef = lift . newCRef
readCRef = lift . readCRef
modifyCRef r = lift . modifyCRef r
atomically = lift . atomically
_concKnowsAbout = lift . _concKnowsAbout
_concForgets = lift . _concForgets
_concAllKnown = lift _concAllKnown
statelazy :: Monad m => (m a -> m b) -> SL.StateT s m a -> SL.StateT s m b
statelazy f ma = SL.StateT $ \s -> (\b -> (b,s)) `liftM` f (SL.evalStateT ma s)
instance MonadConc m => MonadConc (SS.StateT s m) where
type STMLike (SS.StateT s m) = STMLike m
type CVar (SS.StateT s m) = CVar m
type CRef (SS.StateT s m) = CRef m
type ThreadId (SS.StateT s m) = ThreadId m
fork = statestrict fork
forkOn i = statestrict (forkOn i)
forkWithUnmask ma = SS.StateT $ \s -> (\a -> (a,s)) `liftM` forkWithUnmask (\f -> SS.evalStateT (ma $ statestrict f) s)
_concNoTest = statestrict _concNoTest
getNumCapabilities = lift getNumCapabilities
myThreadId = lift myThreadId
throwTo t = lift . throwTo t
newEmptyCVar = lift newEmptyCVar
readCVar = lift . readCVar
putCVar v = lift . putCVar v
tryPutCVar v = lift . tryPutCVar v
takeCVar = lift . takeCVar
tryTakeCVar = lift . tryTakeCVar
newCRef = lift . newCRef
readCRef = lift . readCRef
modifyCRef r = lift . modifyCRef r
atomically = lift . atomically
_concKnowsAbout = lift . _concKnowsAbout
_concForgets = lift . _concForgets
_concAllKnown = lift _concAllKnown
statestrict :: Monad m => (m a -> m b) -> SS.StateT s m a -> SS.StateT s m b
statestrict f ma = SS.StateT $ \s -> (\b -> (b,s)) `liftM` f (SS.evalStateT ma s)
instance (MonadConc m, Monoid w) => MonadConc (RL.RWST r w s m) where
type STMLike (RL.RWST r w s m) = STMLike m
type CVar (RL.RWST r w s m) = CVar m
type CRef (RL.RWST r w s m) = CRef m
type ThreadId (RL.RWST r w s m) = ThreadId m
fork = rwslazy fork
forkOn i = rwslazy (forkOn i)
forkWithUnmask ma = RL.RWST $ \r s -> (\a -> (a,s,mempty)) `liftM` forkWithUnmask (\f -> fst `liftM` RL.evalRWST (ma $ rwslazy f) r s)
_concNoTest = rwslazy _concNoTest
getNumCapabilities = lift getNumCapabilities
myThreadId = lift myThreadId
throwTo t = lift . throwTo t
newEmptyCVar = lift newEmptyCVar
readCVar = lift . readCVar
putCVar v = lift . putCVar v
tryPutCVar v = lift . tryPutCVar v
takeCVar = lift . takeCVar
tryTakeCVar = lift . tryTakeCVar
newCRef = lift . newCRef
readCRef = lift . readCRef
modifyCRef r = lift . modifyCRef r
atomically = lift . atomically
_concKnowsAbout = lift . _concKnowsAbout
_concForgets = lift . _concForgets
_concAllKnown = lift _concAllKnown
rwslazy :: (Monad m, Monoid w) => (m a -> m b) -> RL.RWST r w s m a -> RL.RWST r w s m b
rwslazy f ma = RL.RWST $ \r s -> (\b -> (b,s,mempty)) `liftM` f (fst `liftM` RL.evalRWST ma r s)
instance (MonadConc m, Monoid w) => MonadConc (RS.RWST r w s m) where
type STMLike (RS.RWST r w s m) = STMLike m
type CVar (RS.RWST r w s m) = CVar m
type CRef (RS.RWST r w s m) = CRef m
type ThreadId (RS.RWST r w s m) = ThreadId m
fork = rwsstrict fork
forkOn i = rwsstrict (forkOn i)
forkWithUnmask ma = RS.RWST $ \r s -> (\a -> (a,s,mempty)) `liftM` forkWithUnmask (\f -> fst `liftM` RS.evalRWST (ma $ rwsstrict f) r s)
_concNoTest = rwsstrict _concNoTest
getNumCapabilities = lift getNumCapabilities
myThreadId = lift myThreadId
throwTo t = lift . throwTo t
newEmptyCVar = lift newEmptyCVar
readCVar = lift . readCVar
putCVar v = lift . putCVar v
tryPutCVar v = lift . tryPutCVar v
takeCVar = lift . takeCVar
tryTakeCVar = lift . tryTakeCVar
newCRef = lift . newCRef
readCRef = lift . readCRef
modifyCRef r = lift . modifyCRef r
atomically = lift . atomically
_concKnowsAbout = lift . _concKnowsAbout
_concForgets = lift . _concForgets
_concAllKnown = lift _concAllKnown
rwsstrict :: (Monad m, Monoid w) => (m a -> m b) -> RS.RWST r w s m a -> RS.RWST r w s m b
rwsstrict f ma = RS.RWST $ \r s -> (\b -> (b,s,mempty)) `liftM` f (fst `liftM` RS.evalRWST ma r s)