Closeable.hs

{-# LANGUAGE EmptyDataDecls #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Concurrent.Chan.Closeable
-- Copyright   :  Andrea Vezzosi (based on Control.Concurrent.Chan (c) The University of Glasgow 2001)
-- License     :  BSD-style 
-- 
-- Maintainer  :  sanzhiyan@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable (concurrency)
--
-- Unbounded closeable channels.
--
-----------------------------------------------------------------------------

module Control.Concurrent.Chan.Closeable
  ( 
	  -- * The 'Chan' type
	Chan,R,W,			-- abstract

	  -- * Operations
	newChan, -- :: IO (Chan R a, Chan W a)
        writeChan, -- :: Chan W a -> a -> IO Bool
        closeChan, -- :: Chan W a -> IO Bool
        isClosedChan, -- :: Chan t a -> IO Bool
        readChan, -- :: Chan R a -> IO (Maybe a)
        forkChan, -- :: Chan t a -> IO (Chan R a)
        unGetChan, -- :: Chan R a -> a -> IO ()
        isEmptyChan, -- :: Chan R a -> IO Bool

	  -- * Stream interface
	getChanContents, -- :: Chan R a -> IO [a]
        writeList2Chan, -- :: Chan W a -> [a] -> IO (Maybe [a])

   )
    where

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



-- A channel is represented by two @MVar@s keeping track of the two ends
-- of the channel contents,i.e.,  the read- and write ends. Empty @MVar@s
-- are used to handle consumers trying to read from an empty channel.

-- |'Chan' is an abstract type representing an unbounded FIFO channel.
newtype Chan t a = Chan (MVar (Stream a))
-- |'R' for ReadOnly 
data R 
-- |'W' for WriteOnly
data W 


type Stream a = (MVar (ChItem a)) 

data ChItem a = ChItem a !(Stream a) | Closed



-- @newChan@ sets up the read and write end of a channel by initialising
-- these two @MVar@s with an empty @MVar@.

-- |Build and returns a pair of 'Chan', data written on the W end can be read from the R end.
newChan :: IO (Chan R a,Chan W a)
newChan = do
   hole  <- newEmptyMVar
   read  <- newMVar hole
   write <- newMVar hole
   return (Chan read, Chan write)

-- To put an element on a channel, a new hole at the write end is created.
-- What was previously the empty @MVar@ at the back of the channel is then
-- filled in with a new stream element holding the entered value and the
-- new hole.

-- |Write a value to a 'Chan'.
-- Returns True if successful, False if the channel is closed.
writeChan :: Chan W a -> a -> IO Bool
writeChan (Chan write) val = do
  new_hole <- newEmptyMVar
  modifyMVar write $ \old_hole -> do
    wasempty <- tryPutMVar old_hole (ChItem val new_hole)
    if wasempty then return (new_hole,True)
       else return (old_hole,False)

-- |Close the 'Chan', data can be no more written to it.
-- Returns True if the 'Chan' was already closed.
closeChan :: Chan W a -> IO Bool
closeChan (Chan write) = 
  withMVar write $ \s ->
  not `fmap` tryPutMVar s Closed

-- |Non-blocking check.
isClosedChan :: Chan t a -> IO Bool
isClosedChan (Chan var) =
    withMVar var $ \s -> do
      e <- isEmptyMVar s 
      -- readMVar won't block because a stream is never emptied
      -- i.e. we never use *takeMVar on it
      if e then return False else isClosed `fmap` readMVar s 
    where isClosed Closed = True
          isClosed _      = False
-- |Read the next value from the 'Chan'.
-- |Nothing if the 'Chan' is closed.
readChan :: Chan R a -> IO (Maybe a)
readChan (Chan read) = do
  modifyMVar read $ \read_end -> do
    cItem <- readMVar read_end
        -- Use readMVar here, not takeMVar,
	-- else dupChan doesn't work
    return $ case cItem of
      (ChItem val new_read_end) -> (new_read_end, Just val)
      Closed                    -> (read_end,Nothing)

-- |Forks a 'Chan': data that will be written (W)
-- or is yet to be read (R) on the argument, will also be available on the returned channel.
forkChan :: Chan t a -> IO (Chan R a)
forkChan (Chan write) = do
   hole     <- readMVar write
   new_read <- newMVar hole
   return (Chan new_read)

  

-- |Put a data item back onto a channel, where it will be the next item read.
unGetChan :: Chan R a -> a -> IO ()
unGetChan (Chan read) val = do
   new_read_end <- newEmptyMVar
   modifyMVar_ read $ \read_end -> do
     putMVar new_read_end (ChItem val read_end)
     return (new_read_end)

-- |Returns 'True' if the supplied 'Chan' is empty, i.e. readChan won't block.
isEmptyChan :: Chan R a -> IO Bool
isEmptyChan (Chan read) = do
   withMVar read $ \r -> do 
     isEmptyMVar r

-- Operators for interfacing with functional streams.

-- |Return a lazy list representing the contents of the supplied
-- 'Chan', much like 'System.IO.hGetContents'.
getChanContents :: Chan R a -> IO [a]
getChanContents ch
  = unsafeInterleaveIO (do
	xm <- readChan ch
        case xm of
          Nothing -> return []
    	  Just x -> do xs <- getChanContents ch
    	               return (x:xs)
    )

-- |Write an entire list of items to a 'Chan'.
-- Returning the remainder if the channel has been closed meanwhile.
writeList2Chan :: Chan W a -> [a] -> IO (Maybe [a])
writeList2Chan ch ls = aux ls 
    where write = writeChan ch
          aux [] = return Nothing
          aux l@(x:xs) = do b <- write x
                            if b 
                              then aux xs 
                              else return $ Just l