Evaluate a dependency DAG concurrently communicating state through an MVar.

dep_graph.hs

import Control.Concurrent
import qualified Data.Graph.Inductive.Graph as Gr
import Data.Graph.Inductive.PatriciaTree
import qualified Data.Map.Strict as M
import Control.Monad.Trans.Either
import Control.Monad.Trans (liftIO)
import System.IO

data State = NotStarted | Started | Finished deriving (Show)
type NodeStateMap = M.Map Gr.Node State

graph :: Gr () ()
graph = let aC = ([], 1, (), [])
            bC = ([((), 1)], 2, (), [])
            cC = ([((), 1)], 3, (), [((), 2)])
            dC = ([((), 1)], 4, (), [])
            eC = ([((), 4)], 5, (), [])
            fC = ([((), 3)], 6, (), [])
            gC = ([((), 5), ((),6)], 7, (), [])
        in
            (gC Gr.& (fC Gr.& (eC Gr.& (dC Gr.& (cC Gr.& (bC Gr.& (aC Gr.& Gr.empty)))))))

printGraph :: (Gr.Graph gr, Show a, Show b) => gr a b -> IO ()
printGraph g = do
    putStrLn "Graph:"
    print $ Gr.labEdges g
    print $ Gr.labNodes g

-- Map each node in the graph to a monadic action and sequence according
-- to dependency. Seems like this should be Traversable, but not sure how to
-- do that.
gMapM :: (Monad m) => (Gr.Node -> m a) -> Gr a b -> Gr.Node -> m a
gMapM f gr n = case Gr.suc gr n of
    [] -> do
        f n
    ns -> do
        mapM_ (gMapM f gr) ns
        f n

mkNodeState :: Gr a b -> NodeStateMap
mkNodeState gr = M.fromList (fmap mkNotStarted (Gr.labNodes gr))
    where mkNotStarted (n, _) = (n, NotStarted)

compileNode :: MVar NodeStateMap -> Gr.Node -> EitherT String IO ()
compileNode stateMVar n = do
    stateMap <- liftIO $ takeMVar stateMVar
    let state = M.lookup n stateMap
    case state of
        Just NotStarted -> liftIO $ do
            putMVar stateMVar (M.insert n Started stateMap)
            _ <- forkIO $ do
                putStrLn $ "Compiling " ++ (show n)
                threadDelay 1000000 -- Pretend we're compiling something.
                modifyMVar_ stateMVar (return . M.insert n Finished)
            return ()
        Just Started -> do
            liftIO $ putMVar stateMVar stateMap
            wait stateMVar n
        Just Finished -> liftIO $ putMVar stateMVar stateMap
        Nothing -> left $ "Could not look up state for node " ++ (show n)

-- Block until the specified node has moved to the Finished state.
wait :: MVar NodeStateMap -> Gr.Node -> EitherT String IO ()
wait m n = do
    stateMap <- liftIO $ readMVar m
    case M.lookup n stateMap of
        Just Finished ->
            return ()
        Just _ ->
            wait m n
        Nothing ->
            left $ "Could not look up state for node " ++ (show n)

main :: IO ()
main = do
    printGraph graph
    putStr "Target: "
    hFlush stdout
    target <- fmap read getLine
    nodeState <- newMVar (mkNodeState graph)
    e <- runEitherT $ do
        gMapM (compileNode nodeState) graph target
        wait nodeState target
    case e of
        Left s -> putStrLn s
        Right _ -> return ()

Depends on EitherT and fgl
https://hackage.haskell.org/package/EitherT-0.2.0
http://hackage.haskell.org/package/fgl-5.5.0.1