{-# LANGUAGE Safe #-}
module Control.Concurrent.QSemN
(
QSemN,
newQSemN,
waitQSemN,
signalQSemN
) where
import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar
, putMVar, newMVar
, tryPutMVar, isEmptyMVar)
import Control.Exception
import Data.Maybe
newtype QSemN = QSemN (MVar (Int, [(Int, MVar ())], [(Int, MVar ())]))
newQSemN :: Int -> IO QSemN
newQSemN :: Int -> IO QSemN
newQSemN initial :: Int
initial
| Int
initial Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = String -> IO QSemN
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "newQSemN: Initial quantity must be non-negative"
| Bool
otherwise = do
MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
sem <- (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (MVar (Int, [(Int, MVar ())], [(Int, MVar ())]))
forall a. a -> IO (MVar a)
newMVar (Int
initial, [], [])
QSemN -> IO QSemN
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar (Int, [(Int, MVar ())], [(Int, MVar ())]) -> QSemN
QSemN MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
sem)
waitQSemN :: QSemN -> Int -> IO ()
waitQSemN :: QSemN -> Int -> IO ()
waitQSemN (QSemN m :: MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m) sz :: Int
sz =
IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
(i :: Int
i,b1 :: [(Int, MVar ())]
b1,b2 :: [(Int, MVar ())]
b2) <- MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
forall a. MVar a -> IO a
takeMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m
let z :: Int
z = Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
sz
if Int
z Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0
then do
MVar ()
b <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> (Int, [(Int, MVar ())], [(Int, MVar ())]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m (Int
i, [(Int, MVar ())]
b1, (Int
sz,MVar ()
b)(Int, MVar ()) -> [(Int, MVar ())] -> [(Int, MVar ())]
forall a. a -> [a] -> [a]
:[(Int, MVar ())]
b2)
MVar () -> IO ()
wait MVar ()
b
else do
MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> (Int, [(Int, MVar ())], [(Int, MVar ())]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m (Int
z, [(Int, MVar ())]
b1, [(Int, MVar ())]
b2)
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
wait :: MVar () -> IO ()
wait b :: MVar ()
b = do
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
b IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`onException`
(IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
(i :: Int
i,b1 :: [(Int, MVar ())]
b1,b2 :: [(Int, MVar ())]
b2) <- MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
forall a. MVar a -> IO a
takeMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m
Maybe ()
r <- MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
b
(Int, [(Int, MVar ())], [(Int, MVar ())])
r' <- if Maybe () -> Bool
forall a. Maybe a -> Bool
isJust Maybe ()
r
then Int
-> (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
signal Int
sz (Int
i,[(Int, MVar ())]
b1,[(Int, MVar ())]
b2)
else do MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
b (); (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i,[(Int, MVar ())]
b1,[(Int, MVar ())]
b2)
MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> (Int, [(Int, MVar ())], [(Int, MVar ())]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m (Int, [(Int, MVar ())], [(Int, MVar ())])
r')
signalQSemN :: QSemN -> Int -> IO ()
signalQSemN :: QSemN -> Int -> IO ()
signalQSemN (QSemN m :: MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m) sz :: Int
sz = IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
(Int, [(Int, MVar ())], [(Int, MVar ())])
r <- MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
forall a. MVar a -> IO a
takeMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m
(Int, [(Int, MVar ())], [(Int, MVar ())])
r' <- Int
-> (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
signal Int
sz (Int, [(Int, MVar ())], [(Int, MVar ())])
r
MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> (Int, [(Int, MVar ())], [(Int, MVar ())]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m (Int, [(Int, MVar ())], [(Int, MVar ())])
r'
signal :: Int
-> (Int,[(Int,MVar ())],[(Int,MVar ())])
-> IO (Int,[(Int,MVar ())],[(Int,MVar ())])
signal :: Int
-> (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
signal sz0 :: Int
sz0 (i :: Int
i,a1 :: [(Int, MVar ())]
a1,a2 :: [(Int, MVar ())]
a2) = Int
-> [(Int, MVar ())]
-> [(Int, MVar ())]
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
forall a.
(Num a, Ord a) =>
a
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop (Int
sz0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) [(Int, MVar ())]
a1 [(Int, MVar ())]
a2
where
loop :: a
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop 0 bs :: [(a, MVar ())]
bs b2 :: [(a, MVar ())]
b2 = (a, [(a, MVar ())], [(a, MVar ())])
-> IO (a, [(a, MVar ())], [(a, MVar ())])
forall (m :: * -> *) a. Monad m => a -> m a
return (0, [(a, MVar ())]
bs, [(a, MVar ())]
b2)
loop sz :: a
sz [] [] = (a, [(a, MVar ())], [(a, MVar ())])
-> IO (a, [(a, MVar ())], [(a, MVar ())])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
sz, [], [])
loop sz :: a
sz [] b2 :: [(a, MVar ())]
b2 = a
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop a
sz ([(a, MVar ())] -> [(a, MVar ())]
forall a. [a] -> [a]
reverse [(a, MVar ())]
b2) []
loop sz :: a
sz ((j :: a
j,b :: MVar ()
b):bs :: [(a, MVar ())]
bs) b2 :: [(a, MVar ())]
b2
| a
j a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
sz = do
Bool
r <- MVar () -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar MVar ()
b
if Bool
r then (a, [(a, MVar ())], [(a, MVar ())])
-> IO (a, [(a, MVar ())], [(a, MVar ())])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
sz, (a
j,MVar ()
b)(a, MVar ()) -> [(a, MVar ())] -> [(a, MVar ())]
forall a. a -> [a] -> [a]
:[(a, MVar ())]
bs, [(a, MVar ())]
b2)
else a
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop a
sz [(a, MVar ())]
bs [(a, MVar ())]
b2
| Bool
otherwise = do
Bool
r <- MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
b ()
if Bool
r then a
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop (a
sza -> a -> a
forall a. Num a => a -> a -> a
-a
j) [(a, MVar ())]
bs [(a, MVar ())]
b2
else a
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop a
sz [(a, MVar ())]
bs [(a, MVar ())]
b2