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
res <- m' x
rnf res `seq`
writeChan c res
signalQSem p
foldResults n
| n == 1 = readChan c
| otherwise = do
r1 <- readChan c
r2 <- readChan c
forkWorker (uncurry f) (r1, r2)
foldResults (n 1)