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