module Control.Concurrent.Extra(
module Control.Concurrent,
withNumCapabilities, setNumCapabilities,
forkFinally,
Lock, newLock, withLock, withLockTry,
Var, newVar, readVar, modifyVar, modifyVar_, withVar,
Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe,
) where
import Control.Concurrent
import Control.Exception
import Control.Monad.Extra
withNumCapabilities :: Int -> IO a -> IO a
withNumCapabilities new act | rtsSupportsBoundThreads = do
old <- getNumCapabilities
if old == new then act else
bracket_ (setNumCapabilities new) (setNumCapabilities old) act
#if __GLASGOW_HASKELL__ < 706
setNumCapabilities :: Int -> IO ()
setNumCapabilities n = return ()
#endif
#if __GLASGOW_HASKELL__ < 706
forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally action and_then =
mask $ \restore ->
forkIO $ try (restore action) >>= and_then
#endif
newtype Lock = Lock (MVar ())
newLock :: IO Lock
newLock = fmap Lock $ newMVar ()
withLock :: Lock -> IO a -> IO a
withLock (Lock x) = withMVar x . const
withLockTry :: Lock -> IO a -> IO (Maybe a)
withLockTry (Lock m) act =
mask $ \restore -> do
a <- tryTakeMVar m
case a of
Nothing -> return Nothing
Just _ -> restore (fmap Just act) `finally` putMVar m ()
newtype Var a = Var (MVar a)
newVar :: a -> IO (Var a)
newVar = fmap Var . newMVar
readVar :: Var a -> IO a
readVar (Var x) = readMVar x
modifyVar :: Var a -> (a -> IO (a, b)) -> IO b
modifyVar (Var x) f = modifyMVar x f
modifyVar_ :: Var a -> (a -> IO a) -> IO ()
modifyVar_ (Var x) f = modifyMVar_ x f
withVar :: Var a -> (a -> IO b) -> IO b
withVar (Var x) f = withMVar x f
newtype Barrier a = Barrier (MVar a)
newBarrier :: IO (Barrier a)
newBarrier = fmap Barrier newEmptyMVar
signalBarrier :: Barrier a -> a -> IO ()
signalBarrier (Barrier x) = void . tryPutMVar x
waitBarrier :: Barrier a -> IO a
waitBarrier (Barrier x) = readMVar x
waitBarrierMaybe :: Barrier a -> IO (Maybe a)
waitBarrierMaybe (Barrier x) = do
res <- tryTakeMVar x
whenJust res $ void . tryPutMVar x
return res