{-# 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

-- ------------------------------------------------------------