{-# LANGUAGE BangPatterns #-}
module Control.Concurrent.Chan.Strict (
Chan,
newChan,
writeChan,
readChan,
dupChan,
unGetChan,
isEmptyChan,
getChanContents,
writeList2Chan,
) where
import Prelude
import System.IO.Unsafe ( unsafeInterleaveIO )
import Control.Concurrent.MVar.Strict
import Control.DeepSeq
data Chan a
= Chan (MVar (Stream a))
(MVar (Stream a))
type Stream a = MVar (ChItem a)
data ChItem a = ChItem !a (Stream a)
instance NFData a => NFData (ChItem a) where
rnf :: ChItem a -> ()
rnf (ChItem a
a Stream a
s) = a -> ()
forall a. NFData a => a -> ()
rnf a
a () -> () -> ()
`seq` Stream a -> ()
forall a. NFData a => a -> ()
rnf Stream a
s
newChan :: NFData a => IO (Chan a)
newChan :: IO (Chan a)
newChan = do
MVar (ChItem a)
hole <- IO (MVar (ChItem a))
forall a. IO (MVar a)
newEmptyMVar
MVar (MVar (ChItem a))
readm <- MVar (ChItem a) -> IO (MVar (MVar (ChItem a)))
forall a. NFData a => a -> IO (MVar a)
newMVar MVar (ChItem a)
hole
MVar (MVar (ChItem a))
write <- MVar (ChItem a) -> IO (MVar (MVar (ChItem a)))
forall a. NFData a => a -> IO (MVar a)
newMVar MVar (ChItem a)
hole
Chan a -> IO (Chan a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar (MVar (ChItem a)) -> MVar (MVar (ChItem a)) -> Chan a
forall a. MVar (Stream a) -> MVar (Stream a) -> Chan a
Chan MVar (MVar (ChItem a))
readm MVar (MVar (ChItem a))
write)
writeChan :: NFData a => Chan a -> a -> IO ()
writeChan :: Chan a -> a -> IO ()
writeChan (Chan MVar (Stream a)
_read MVar (Stream a)
write) a
val = do
Stream a
new_hole <- IO (Stream a)
forall a. IO (MVar a)
newEmptyMVar
MVar (Stream a) -> (Stream a -> IO (Stream a)) -> IO ()
forall a. NFData a => MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Stream a)
write ((Stream a -> IO (Stream a)) -> IO ())
-> (Stream a -> IO (Stream a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Stream a
old_hole -> do
Stream a -> ChItem a -> IO ()
forall a. NFData a => MVar a -> a -> IO ()
putMVar Stream a
old_hole (ChItem a -> IO ()) -> ChItem a -> IO ()
forall a b. (a -> b) -> a -> b
$! a -> Stream a -> ChItem a
forall a. a -> Stream a -> ChItem a
ChItem a
val Stream a
new_hole
Stream a -> IO (Stream a)
forall (m :: * -> *) a. Monad m => a -> m a
return Stream a
new_hole
readChan :: NFData a => Chan a -> IO a
readChan :: Chan a -> IO a
readChan (Chan MVar (Stream a)
readm MVar (Stream a)
_write) = do
MVar (Stream a) -> (Stream a -> IO (Stream a, a)) -> IO a
forall a b. NFData a => MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Stream a)
readm ((Stream a -> IO (Stream a, a)) -> IO a)
-> (Stream a -> IO (Stream a, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \Stream a
read_end -> do
(ChItem a
val Stream a
new_read_end) <- Stream a -> IO (ChItem a)
forall a. NFData a => MVar a -> IO a
readMVar Stream a
read_end
(Stream a, a) -> IO (Stream a, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream a
new_read_end, a
val)
dupChan :: NFData a => Chan a -> IO (Chan a)
dupChan :: Chan a -> IO (Chan a)
dupChan (Chan MVar (Stream a)
_read MVar (Stream a)
write) = do
Stream a
hole <- MVar (Stream a) -> IO (Stream a)
forall a. NFData a => MVar a -> IO a
readMVar MVar (Stream a)
write
MVar (Stream a)
new_read <- Stream a -> IO (MVar (Stream a))
forall a. NFData a => a -> IO (MVar a)
newMVar Stream a
hole
Chan a -> IO (Chan a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar (Stream a) -> MVar (Stream a) -> Chan a
forall a. MVar (Stream a) -> MVar (Stream a) -> Chan a
Chan MVar (Stream a)
new_read MVar (Stream a)
write)
unGetChan :: NFData a => Chan a -> a -> IO ()
unGetChan :: Chan a -> a -> IO ()
unGetChan (Chan MVar (Stream a)
readm MVar (Stream a)
_write) a
val = do
Stream a
new_read_end <- IO (Stream a)
forall a. IO (MVar a)
newEmptyMVar
MVar (Stream a) -> (Stream a -> IO (Stream a)) -> IO ()
forall a. NFData a => MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Stream a)
readm ((Stream a -> IO (Stream a)) -> IO ())
-> (Stream a -> IO (Stream a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Stream a
read_end -> do
Stream a -> ChItem a -> IO ()
forall a. NFData a => MVar a -> a -> IO ()
putMVar Stream a
new_read_end (a -> Stream a -> ChItem a
forall a. a -> Stream a -> ChItem a
ChItem a
val Stream a
read_end)
Stream a -> IO (Stream a)
forall (m :: * -> *) a. Monad m => a -> m a
return Stream a
new_read_end
isEmptyChan ::NFData a => Chan a -> IO Bool
isEmptyChan :: Chan a -> IO Bool
isEmptyChan (Chan MVar (Stream a)
readm MVar (Stream a)
write) = do
MVar (Stream a) -> (Stream a -> IO Bool) -> IO Bool
forall a b. NFData a => MVar a -> (a -> IO b) -> IO b
withMVar MVar (Stream a)
readm ((Stream a -> IO Bool) -> IO Bool)
-> (Stream a -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Stream a
r -> do
Stream a
w <- MVar (Stream a) -> IO (Stream a)
forall a. NFData a => MVar a -> IO a
readMVar MVar (Stream a)
write
let eq :: Bool
eq = Stream a
r Stream a -> Stream a -> Bool
forall a. Eq a => a -> a -> Bool
== Stream a
w
Bool
eq Bool -> IO Bool -> IO Bool
`seq` Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
eq
getChanContents ::NFData a => Chan a -> IO [a]
getChanContents :: Chan a -> IO [a]
getChanContents Chan a
ch = IO [a] -> IO [a]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [a] -> IO [a]) -> IO [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ do
a
x <- Chan a -> IO a
forall a. NFData a => Chan a -> IO a
readChan Chan a
ch
[a]
xs <- Chan a -> IO [a]
forall a. NFData a => Chan a -> IO [a]
getChanContents Chan a
ch
[a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
writeList2Chan ::NFData a => Chan a -> [a] -> IO ()
writeList2Chan :: Chan a -> [a] -> IO ()
writeList2Chan = (a -> IO ()) -> [a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((a -> IO ()) -> [a] -> IO ())
-> (Chan a -> a -> IO ()) -> Chan a -> [a] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chan a -> a -> IO ()
forall a. NFData a => Chan a -> a -> IO ()
writeChan