content: {-# OPTIONS #-}
  
  -- ------------------------------------------------------------
  
  {- |
     Module     : Control.Concurrent.MapFold
     Copyright  : Copyright (C) 2010 Uwe Schmidt
     License    : MIT
  
     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
     Stability  : experimental
     Portability: none portable
  
     A map-fold function for performing list folds in parallel.
  
  -}
  
  -- ------------------------------------------------------------
  
  module Control.Concurrent.MapFold
      ( mapFold )
  where
  
  import Control.Concurrent
  import Control.DeepSeq
  
  -- ------------------------------------------------------------
  
  mapFold			:: (NFData b) => Int -> (a -> IO b) -> (b -> b -> IO b) -> [a] -> IO b
  mapFold n m f xs@(_:_)	= do
  			  c <- newChan
  			  p <- newQSem n
  			  mapFold' p c m f xs
  mapFold _ _ _ []	= error "mapFold: empty list of arguments"
  
  mapFold'		:: (NFData b) => QSem -> Chan b -> (a -> IO b) -> (b -> b -> IO b) -> [a] -> IO b
  mapFold' p c m f xs	= do
  			  mapM_ (forkWorker m) xs
  			  foldResults (length xs)
      where
      forkWorker m' x	= forkIO process
  			  >> return ()
  	where
  	process		= do
  			  waitQSem p		-- request processor
  			  res <- m' x		-- work
  			  rnf res `seq`		-- force complete elvaluation
                                writeChan c res	-- deliver result
  			  signalQSem p		-- release processor
  
  
      foldResults n
  	| n == 1	= readChan c		-- get final result
  
  	| otherwise	= do
  			  r1 <- readChan c	-- get 1. arg
  			  r2 <- readChan c	-- get 2. arg
  			  forkWorker (uncurry f) (r1, r2)
  						-- combine args and put result back into chanel
  			  foldResults (n - 1)	-- continue
  
  -- ------------------------------------------------------------
  
  