Control/Concurrent/Chan.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Control.Concurrent.Chan
   4 -- Copyright   :  (c) The University of Glasgow 2001
   5 -- License     :  BSD-style (see the file libraries/core/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  experimental
   9 -- Portability :  non-portable
  10 --
  11 -- Standard, unbounded channel abstraction.
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Control.Concurrent.Chan
  16         ( Chan                  -- abstract
  17
  18           -- creator
  19         , newChan               -- :: IO (Chan a)
  20
  21           -- operators
  22         , writeChan             -- :: Chan a -> a -> IO ()
  23         , readChan              -- :: Chan a -> IO a
  24         , dupChan               -- :: Chan a -> IO (Chan a)
  25         , unGetChan             -- :: Chan a -> a -> IO ()
  26
  27         , isEmptyChan           -- :: Chan a -> IO Bool
  28
  29           -- stream interface
  30         , getChanContents       -- :: Chan a -> IO [a]
  31         , writeList2Chan        -- :: Chan a -> [a] -> IO ()
  32
  33        ) where
  34
  35 import Prelude
  36
  37 import System.IO.Unsafe         ( unsafeInterleaveIO )
  38 import Control.Concurrent.MVar
  39
  40 -- A channel is represented by two @MVar@s keeping track of the two ends
  41 -- of the channel contents,i.e.,  the read- and write ends. Empty @MVar@s
  42 -- are used to handle consumers trying to read from an empty channel.
  43
  44 data Chan a
  45  = Chan (MVar (Stream a))
  46         (MVar (Stream a))
  47
  48 type Stream a = MVar (ChItem a)
  49
  50 data ChItem a = ChItem a (Stream a)
  51
  52 -- See the Concurrent Haskell paper for a diagram explaining the
  53 -- how the different channel operations proceed.
  54
  55 -- @newChan@ sets up the read and write end of a channel by initialising
  56 -- these two @MVar@s with an empty @MVar@.
  57
  58 newChan :: IO (Chan a)
  59 newChan = do
  60    hole  <- newEmptyMVar
  61    read  <- newMVar hole
  62    write <- newMVar hole
  63    return (Chan read write)
  64
  65 -- To put an element on a channel, a new hole at the write end is created.
  66 -- What was previously the empty @MVar@ at the back of the channel is then
  67 -- filled in with a new stream element holding the entered value and the
  68 -- new hole.
  69
  70 writeChan :: Chan a -> a -> IO ()
  71 writeChan (Chan _read write) val = do
  72   new_hole <- newEmptyMVar
  73   modifyMVar_ write $ \old_hole -> do
  74     putMVar old_hole (ChItem val new_hole)
  75     return new_hole
  76
  77 readChan :: Chan a -> IO a
  78 readChan (Chan read _write) = do
  79   modifyMVar read $ \read_end -> do
  80     (ChItem val new_read_end) <- readMVar read_end
  81         -- Use readMVar here, not takeMVar,
  82         -- else dupChan doesn't work
  83     return (new_read_end, val)
  84
  85 dupChan :: Chan a -> IO (Chan a)
  86 dupChan (Chan _read write) = do
  87    hole     <- readMVar write
  88    new_read <- newMVar hole
  89    return (Chan new_read write)
  90
  91 unGetChan :: Chan a -> a -> IO ()
  92 unGetChan (Chan read _write) val = do
  93    new_read_end <- newEmptyMVar
  94    modifyMVar_ read $ \read_end -> do
  95      putMVar new_read_end (ChItem val read_end)
  96      return new_read_end
  97
  98 isEmptyChan :: Chan a -> IO Bool
  99 isEmptyChan (Chan read write) = do
 100    withMVar read $ \r -> do
 101      w <- readMVar write
 102      let eq = r == w
 103      eq `seq` return eq
 104
 105 -- Operators for interfacing with functional streams.
 106
 107 getChanContents :: Chan a -> IO [a]
 108 getChanContents ch
 109   = unsafeInterleaveIO (do
 110         x  <- readChan ch
 111         xs <- getChanContents ch
 112         return (x:xs)
 113     )
 114
 115 -------------
 116 writeList2Chan :: Chan a -> [a] -> IO ()
 117 writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)