From b6d4bc5d0ed7cab765b4396f9764131cf802636d Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 1 Oct 2010 19:22:59 +0200 Subject: Add concurrency features --- src/Text/Hakyll/HakyllMonad.hs | 25 +++++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Text/Hakyll/HakyllMonad.hs b/src/Text/Hakyll/HakyllMonad.hs index 40e8c75..f51cf2c 100644 --- a/src/Text/Hakyll/HakyllMonad.hs +++ b/src/Text/Hakyll/HakyllMonad.hs @@ -6,11 +6,14 @@ module Text.Hakyll.HakyllMonad , askHakyll , getAdditionalContext , logHakyll + , forkHakyllWait + , concurrentHakyll ) where import Control.Monad.Trans (liftIO) -import Control.Monad.Reader (ReaderT, ask) -import Control.Monad (liftM) +import Control.Concurrent.MVar (MVar, putMVar, newEmptyMVar, readMVar) +import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Control.Monad (liftM, forM, forM_) import qualified Data.Map as M import System.IO (hPutStrLn, stderr) @@ -76,3 +79,21 @@ getAdditionalContext configuration = -- logHakyll :: String -> Hakyll () logHakyll = liftIO . hPutStrLn stderr + +-- | Perform a concurrent hakyll action. Returns an MVar you can wait on +-- +forkHakyllWait :: Hakyll () -> Hakyll (MVar ()) +forkHakyllWait action = do + mvar <- liftIO newEmptyMVar + config <- ask + liftIO $ do + runReaderT action config + putMVar mvar () + return mvar + +-- | Perform a number of concurrent hakyll actions, and waits for them to finish +-- +concurrentHakyll :: [Hakyll ()] -> Hakyll () +concurrentHakyll actions = do + mvars <- forM actions forkHakyllWait + forM_ mvars (liftIO . readMVar) -- cgit v1.2.3