(original) (raw)

{-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP #-}

module Control.Concurrent.Chan (

    [Chan](Control.Concurrent.Chan.html#Chan),                   

      
    [newChan](Control.Concurrent.Chan.html#newChan),
    [writeChan](Control.Concurrent.Chan.html#writeChan),
    [readChan](Control.Concurrent.Chan.html#readChan),
    [dupChan](Control.Concurrent.Chan.html#dupChan),

      
    [getChanContents](Control.Concurrent.Chan.html#getChanContents),
    [writeList2Chan](Control.Concurrent.Chan.html#writeList2Chan),

) where

import System.IO.Unsafe ( unsafeInterleaveIO ) import Control.Concurrent.MVar import Control.Exception (mask_)

#define UPK(x) {-# UNPACK #-} !(x)

data Chan a = Chan UPK(MVar (Stream a)) UPK(MVar (Stream a)) deriving Chan a -> Chan a -> Bool (Chan a -> Chan a -> Bool) -> (Chan a -> Chan a -> Bool) -> Eq (Chan a) forall a. Chan a -> Chan a -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Chan a -> Chan a -> Bool $c/= :: forall a. Chan a -> Chan a -> Bool == :: Chan a -> Chan a -> Bool $c== :: forall a. Chan a -> Chan a -> Bool Eq

type Stream a = MVar (ChItem a)

data ChItem a = ChItem a UPK(Stream a)

newChan :: IO (Chan a) newChan :: forall a. IO (Chan a) newChan = do MVar (ChItem a) hole <- IO (MVar (ChItem a)) forall a. IO (MVar a) newEmptyMVar MVar (MVar (ChItem a)) readVar <- MVar (ChItem a) -> IO (MVar (MVar (ChItem a))) forall a. a -> IO (MVar a) newMVar MVar (ChItem a) hole MVar (MVar (ChItem a)) writeVar <- MVar (ChItem a) -> IO (MVar (MVar (ChItem a))) forall 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)) readVar MVar (MVar (ChItem a)) writeVar)

writeChan :: Chan a -> a -> IO () writeChan :: forall a. Chan a -> a -> IO () writeChan (Chan MVar (Stream a) _ MVar (Stream a) writeVar) a val = do Stream a new_hole <- IO (Stream a) forall a. IO (MVar a) newEmptyMVar IO () -> IO () forall a. IO a -> IO a mask_ (IO () -> IO ()) -> IO () -> IO () forall a b. (a -> b) -> a -> b $ do Stream a old_hole <- MVar (Stream a) -> IO (Stream a) forall a. MVar a -> IO a takeMVar MVar (Stream a) writeVar Stream a -> ChItem a -> IO () forall a. MVar a -> a -> IO () putMVar Stream a old_hole (a -> Stream a -> ChItem a forall a. a -> Stream a -> ChItem a ChItem a val Stream a new_hole) MVar (Stream a) -> Stream a -> IO () forall a. MVar a -> a -> IO () putMVar MVar (Stream a) writeVar Stream a new_hole

readChan :: Chan a -> IO a readChan :: forall a. Chan a -> IO a readChan (Chan MVar (Stream a) readVar MVar (Stream a) _) = MVar (Stream a) -> (Stream a -> IO (Stream a, a)) -> IO a forall a b. MVar a -> (a -> IO (a, b)) -> IO b modifyMVar MVar (Stream a) readVar ((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. 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 :: Chan a -> IO (Chan a) dupChan :: forall a. Chan a -> IO (Chan a) dupChan (Chan MVar (Stream a) _ MVar (Stream a) writeVar) = do Stream a hole <- MVar (Stream a) -> IO (Stream a) forall a. MVar a -> IO a readMVar MVar (Stream a) writeVar MVar (Stream a) newReadVar <- Stream a -> IO (MVar (Stream a)) forall 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) newReadVar MVar (Stream a) writeVar)

getChanContents :: Chan a -> IO [a] getChanContents :: forall a. Chan a -> IO [a] getChanContents Chan a ch = IO [a] -> IO [a] forall a. IO a -> IO a unsafeInterleaveIO (do a x <- Chan a -> IO a forall a. Chan a -> IO a readChan Chan a ch [a] xs <- Chan a -> IO [a] forall 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 :: Chan a -> [a] -> IO () writeList2Chan :: forall a. Chan a -> [a] -> IO () writeList2Chan Chan a ch [a] ls = [IO ()] -> IO () forall (t :: * -> *) (m :: * -> *) a. (Foldable t, Monad m) => t (m a) -> m () sequence_ ((a -> IO ()) -> [a] -> [IO ()] forall a b. (a -> b) -> [a] -> [b] map (Chan a -> a -> IO () forall a. Chan a -> a -> IO () writeChan Chan a ch) [a] ls)