{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#endif
module Control.Concurrent.Broadcast
( Broadcast
, new
, newBroadcasting
, listen
, tryListen
, listenTimeout
, broadcast
, signal
, silence
) where
import Control.Monad ( return, when )
import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar
, takeMVar, putMVar, readMVar, modifyMVar_
)
import Control.Exception ( onException )
import Data.Eq ( Eq )
import Data.Either ( Either(Left ,Right), either )
import Data.Function ( ($), (.), const )
import Data.Functor ( fmap, (<$>) )
import Data.Foldable ( for_ )
import Data.List ( delete, length )
import Data.Maybe ( Maybe(Nothing, Just), isNothing )
import Data.Ord ( max )
import Data.Typeable ( Typeable )
import Prelude ( Integer, seq )
import System.IO ( IO )
#if __GLASGOW_HASKELL__ < 700
import Prelude ( fromInteger )
import Control.Monad ( (>>=), (>>), fail )
import Data.Ord ( Ord )
#endif
import Control.Concurrent.Timeout ( timeout )
import Utils ( purelyModifyMVar, mask_ )
newtype Broadcast a = Broadcast {forall a. Broadcast a -> MVar (Either [MVar a] a)
unBroadcast :: MVar (Either [MVar a] a)}
deriving (Broadcast a -> Broadcast a -> Bool
(Broadcast a -> Broadcast a -> Bool)
-> (Broadcast a -> Broadcast a -> Bool) -> Eq (Broadcast a)
forall a. Broadcast a -> Broadcast a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Broadcast a -> Broadcast a -> Bool
== :: Broadcast a -> Broadcast a -> Bool
$c/= :: forall a. Broadcast a -> Broadcast a -> Bool
/= :: Broadcast a -> Broadcast a -> Bool
Eq, Typeable)
new :: IO (Broadcast a)
new :: forall a. IO (Broadcast a)
new = MVar (Either [MVar a] a) -> Broadcast a
forall a. MVar (Either [MVar a] a) -> Broadcast a
Broadcast (MVar (Either [MVar a] a) -> Broadcast a)
-> IO (MVar (Either [MVar a] a)) -> IO (Broadcast a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either [MVar a] a -> IO (MVar (Either [MVar a] a))
forall a. a -> IO (MVar a)
newMVar ([MVar a] -> Either [MVar a] a
forall a b. a -> Either a b
Left [])
newBroadcasting :: a -> IO (Broadcast a)
newBroadcasting :: forall a. a -> IO (Broadcast a)
newBroadcasting a
x = MVar (Either [MVar a] a) -> Broadcast a
forall a. MVar (Either [MVar a] a) -> Broadcast a
Broadcast (MVar (Either [MVar a] a) -> Broadcast a)
-> IO (MVar (Either [MVar a] a)) -> IO (Broadcast a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either [MVar a] a -> IO (MVar (Either [MVar a] a))
forall a. a -> IO (MVar a)
newMVar (a -> Either [MVar a] a
forall a b. b -> Either a b
Right a
x)
listen :: Broadcast a -> IO a
listen :: forall a. Broadcast a -> IO a
listen (Broadcast MVar (Either [MVar a] a)
mv) = IO a -> IO a
forall a. IO a -> IO a
mask_ (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
Either [MVar a] a
mx <- MVar (Either [MVar a] a) -> IO (Either [MVar a] a)
forall a. MVar a -> IO a
takeMVar MVar (Either [MVar a] a)
mv
case Either [MVar a] a
mx of
Left [MVar a]
ls -> do MVar a
l <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
MVar (Either [MVar a] a) -> Either [MVar a] a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either [MVar a] a)
mv (Either [MVar a] a -> IO ()) -> Either [MVar a] a -> IO ()
forall a b. (a -> b) -> a -> b
$ [MVar a] -> Either [MVar a] a
forall a b. a -> Either a b
Left ([MVar a] -> Either [MVar a] a) -> [MVar a] -> Either [MVar a] a
forall a b. (a -> b) -> a -> b
$ MVar a
lMVar a -> [MVar a] -> [MVar a]
forall a. a -> [a] -> [a]
:[MVar a]
ls
MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
l
Right a
x -> do MVar (Either [MVar a] a) -> Either [MVar a] a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either [MVar a] a)
mv Either [MVar a] a
mx
a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
tryListen :: Broadcast a -> IO (Maybe a)
tryListen :: forall a. Broadcast a -> IO (Maybe a)
tryListen = (Either [MVar a] a -> Maybe a)
-> IO (Either [MVar a] a) -> IO (Maybe a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([MVar a] -> Maybe a)
-> (a -> Maybe a) -> Either [MVar a] a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> [MVar a] -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just) (IO (Either [MVar a] a) -> IO (Maybe a))
-> (Broadcast a -> IO (Either [MVar a] a))
-> Broadcast a
-> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar (Either [MVar a] a) -> IO (Either [MVar a] a)
forall a. MVar a -> IO a
readMVar (MVar (Either [MVar a] a) -> IO (Either [MVar a] a))
-> (Broadcast a -> MVar (Either [MVar a] a))
-> Broadcast a
-> IO (Either [MVar a] a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Broadcast a -> MVar (Either [MVar a] a)
forall a. Broadcast a -> MVar (Either [MVar a] a)
unBroadcast
listenTimeout :: Broadcast a -> Integer -> IO (Maybe a)
listenTimeout :: forall a. Broadcast a -> Integer -> IO (Maybe a)
listenTimeout (Broadcast MVar (Either [MVar a] a)
mv) Integer
time = IO (Maybe a) -> IO (Maybe a)
forall a. IO a -> IO a
mask_ (IO (Maybe a) -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
Either [MVar a] a
mx <- MVar (Either [MVar a] a) -> IO (Either [MVar a] a)
forall a. MVar a -> IO a
takeMVar MVar (Either [MVar a] a)
mv
case Either [MVar a] a
mx of
Left [MVar a]
ls -> do MVar a
l <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
MVar (Either [MVar a] a) -> Either [MVar a] a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either [MVar a] a)
mv (Either [MVar a] a -> IO ()) -> Either [MVar a] a -> IO ()
forall a b. (a -> b) -> a -> b
$ [MVar a] -> Either [MVar a] a
forall a b. a -> Either a b
Left ([MVar a] -> Either [MVar a] a) -> [MVar a] -> Either [MVar a] a
forall a b. (a -> b) -> a -> b
$ MVar a
lMVar a -> [MVar a] -> [MVar a]
forall a. a -> [a] -> [a]
:[MVar a]
ls
Maybe a
my <- Integer -> IO a -> IO (Maybe a)
forall α. Integer -> IO α -> IO (Maybe α)
timeout (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
time Integer
0) (MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
l)
IO (Maybe a) -> IO () -> IO (Maybe a)
forall a b. IO a -> IO b -> IO a
`onException` MVar a -> IO ()
deleteReader MVar a
l
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing Maybe a
my) (MVar a -> IO ()
deleteReader MVar a
l)
Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
my
Right a
x -> do MVar (Either [MVar a] a) -> Either [MVar a] a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either [MVar a] a)
mv Either [MVar a] a
mx
Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
where
deleteReader :: MVar a -> IO ()
deleteReader MVar a
l = do Either [MVar a] a
mx <- MVar (Either [MVar a] a) -> IO (Either [MVar a] a)
forall a. MVar a -> IO a
takeMVar MVar (Either [MVar a] a)
mv
case Either [MVar a] a
mx of
Left [MVar a]
ls -> let ls' :: [MVar a]
ls' = MVar a -> [MVar a] -> [MVar a]
forall a. Eq a => a -> [a] -> [a]
delete MVar a
l [MVar a]
ls
in [MVar a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MVar a]
ls' Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq` MVar (Either [MVar a] a) -> Either [MVar a] a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either [MVar a] a)
mv ([MVar a] -> Either [MVar a] a
forall a b. a -> Either a b
Left [MVar a]
ls')
Right a
_ -> MVar (Either [MVar a] a) -> Either [MVar a] a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either [MVar a] a)
mv Either [MVar a] a
mx
broadcast :: Broadcast a -> a -> IO ()
signal :: Broadcast a -> a -> IO ()
broadcast :: forall a. Broadcast a -> a -> IO ()
broadcast Broadcast a
b a
x = Either [MVar a] a -> Broadcast a -> a -> IO ()
forall a. Either [MVar a] a -> Broadcast a -> a -> IO ()
broadcastThen (a -> Either [MVar a] a
forall a b. b -> Either a b
Right a
x) Broadcast a
b a
x
signal :: forall a. Broadcast a -> a -> IO ()
signal Broadcast a
b a
x = Either [MVar a] a -> Broadcast a -> a -> IO ()
forall a. Either [MVar a] a -> Broadcast a -> a -> IO ()
broadcastThen ([MVar a] -> Either [MVar a] a
forall a b. a -> Either a b
Left []) Broadcast a
b a
x
broadcastThen :: Either [MVar a] a -> Broadcast a -> a -> IO ()
broadcastThen :: forall a. Either [MVar a] a -> Broadcast a -> a -> IO ()
broadcastThen Either [MVar a] a
finalState (Broadcast MVar (Either [MVar a] a)
mv) a
x =
MVar (Either [MVar a] a)
-> (Either [MVar a] a -> IO (Either [MVar a] a)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Either [MVar a] a)
mv ((Either [MVar a] a -> IO (Either [MVar a] a)) -> IO ())
-> (Either [MVar a] a -> IO (Either [MVar a] a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Either [MVar a] a
mx -> do
case Either [MVar a] a
mx of
Left [MVar a]
ls -> do [MVar a] -> (MVar a -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [MVar a]
ls (MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
`putMVar` a
x)
Either [MVar a] a -> IO (Either [MVar a] a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either [MVar a] a
finalState
Right a
_ -> Either [MVar a] a -> IO (Either [MVar a] a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either [MVar a] a
finalState
silence :: Broadcast a -> IO ()
silence :: forall a. Broadcast a -> IO ()
silence (Broadcast MVar (Either [MVar a] a)
mv) = MVar (Either [MVar a] a)
-> (Either [MVar a] a -> Either [MVar a] a) -> IO ()
forall a. MVar a -> (a -> a) -> IO ()
purelyModifyMVar MVar (Either [MVar a] a)
mv ((Either [MVar a] a -> Either [MVar a] a) -> IO ())
-> (Either [MVar a] a -> Either [MVar a] a) -> IO ()
forall a b. (a -> b) -> a -> b
$ ([MVar a] -> Either [MVar a] a)
-> (a -> Either [MVar a] a)
-> Either [MVar a] a
-> Either [MVar a] a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [MVar a] -> Either [MVar a] a
forall a b. a -> Either a b
Left ((a -> Either [MVar a] a)
-> Either [MVar a] a -> Either [MVar a] a)
-> (a -> Either [MVar a] a)
-> Either [MVar a] a
-> Either [MVar a] a
forall a b. (a -> b) -> a -> b
$ Either [MVar a] a -> a -> Either [MVar a] a
forall a b. a -> b -> a
const (Either [MVar a] a -> a -> Either [MVar a] a)
-> Either [MVar a] a -> a -> Either [MVar a] a
forall a b. (a -> b) -> a -> b
$ [MVar a] -> Either [MVar a] a
forall a b. a -> Either a b
Left []