Most of the work on topological sorting of tests

Stackage/Test.hs

@@ -29,7 +29,9 @@ import Data.IORef (IORef, readIORef, atomicModifyIORef, newIORef)
 runTestSuites :: BuildSettings -> BuildPlan -> IO ()
 runTestSuites settings' bp = do
     settings <- fixBuildSettings settings'
-    let selected = Map.filterWithKey notSkipped $ bpPackages bp
+    let selected' = Map.filterWithKey notSkipped $ bpPackages bp
+    putStrLn "Determining package dependencies"
+    selected <- mapM (addDependencies settings) $ Map.toList selected'
     putStrLn "Running test suites"
     let testdir = "runtests"
         docdir = "haddock"
@@ -42,11 +44,31 @@ runTestSuites settings' bp = do
 
     cabalVersion <- getCabalVersion
     haddockFilesRef <- newIORef []
-    allPass <- parFoldM (testWorkerThreads settings) (runTestSuite cabalVersion settings testdir docdir bp haddockFilesRef) (&&) True $ Map.toList selected
+    allPass <- parFoldM
+        (testWorkerThreads settings)
+        (runTestSuite cabalVersion settings testdir docdir bp haddockFilesRef)
+        (&&)
+        True
+        selected
     unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
   where
     notSkipped p _ = p `Set.notMember` bpSkippedTests bp
 
+addDependencies :: BuildSettings
+                -> (PackageName, SelectedPackageInfo)
+                -> IO (PackageName, Set PackageName, SelectedPackageInfo)
+addDependencies settings (packageName, spi) = do
+    package' <- replaceTarball (tarballDir settings) package
+    deps <- handle (\e -> print (e :: IOException) >> return Set.empty)
+          $ getDeps package'
+    return (packageName, Set.empty, spi) -- FIXME
+  where
+    package = packageVersionString (packageName, spiVersion spi)
+
+getDeps :: String -> IO (Set PackageName)
+getDeps name = do
+    return Set.empty -- FIXME
+
 getCabalVersion :: IO CabalVersion
 getCabalVersion = do
     output <- readProcess "cabal" ["--numeric-version"] ""
@@ -58,35 +80,42 @@ getCabalVersion = do
     notCRLF '\r' = False
     notCRLF _    = True
 
-parFoldM :: Int -- ^ number of threads
-         -> (b -> IO c)
+parFoldM :: (Ord key, Show key)
+         => Int -- ^ number of threads
+         -> ((key, payload) -> IO c)
          -> (a -> c -> a)
          -> a
-         -> [b]
+         -> [(key, Set key, payload)]
          -> IO a
 parFoldM threadCount0 f g a0 bs0 = do
     ma <- C.newMVar a0
     mbs <- C.newMVar bs0
     signal <- C.newEmptyMVar
-    tids <- replicateM threadCount0 $ C.forkIO $ worker ma mbs signal
+    completed <- newIORef Set.empty
+    tids <- replicateM threadCount0 $ C.forkIO $ worker completed ma mbs signal
     wait threadCount0 signal tids
+    [] <- C.takeMVar mbs -- ensure all tests were run
     C.takeMVar ma
   where
-    worker ma mbs signal =
+    worker completedRef ma mbs signal =
         handle
             (C.putMVar signal . Just)
             (loop >> C.putMVar signal Nothing)
       where
         loop = do
-            mb <- C.modifyMVar mbs $ \bs -> return $
-                case bs of
-                    [] -> ([], Nothing)
-                    b:bs' -> (bs', Just b)
+            mb <- C.modifyMVar mbs $ \bs -> do
+                completed <- readIORef completedRef
+                return $ case findReady completed bs of
+                    -- There's a workload ready with no deps
+                    Just (b, bs') -> (bs', Just b)
+                    -- No workload with no deps
+                    Nothing -> (bs, Nothing)
             case mb of
                 Nothing -> return ()
-                Just b -> do
-                    c <- f b
+                Just (name, _, payload) -> do
+                    c <- f (name, payload)
                     C.modifyMVar_ ma $ \a -> return $! g a c
+                    atomicModifyIORef completedRef $ \s -> (Set.insert name s, ())
                     loop
     wait threadCount signal tids
         | threadCount == 0 = return ()
@@ -98,6 +127,19 @@ parFoldM threadCount0 f g a0 bs0 = do
                     mapM_ C.killThread tids
                     throwIO (e :: SomeException)
 
+-- | Find a workload whose dependencies have been met.
+findReady :: Ord key
+          => Set key -- ^ workloads already complete
+          -> [(key, Set key, value)]
+          -> Maybe ((key, Set key, value), [(key, Set key, value)])
+findReady completed =
+    loop id
+  where
+    loop _ [] = Nothing
+    loop front (x@(_, deps, _):xs)
+        | Set.null $ Set.difference deps completed = Just (x, front xs)
+        | otherwise = loop (front . (x:)) xs
+
 data TestException = TestException
     deriving (Show, Typeable)
 instance Exception TestException
@@ -110,7 +152,7 @@ runTestSuite :: CabalVersion
              -> FilePath -- ^ testdir
              -> FilePath -- ^ docdir
              -> BuildPlan
-             -> IORef [FilePath] -- ^ .haddock files
+             -> IORef [(String, FilePath)] -- ^ .haddock files
              -> (PackageName, SelectedPackageInfo)
              -> IO Bool
 runTestSuite cabalVersion settings testdir docdir
@@ -142,7 +184,13 @@ runTestSuite cabalVersion settings testdir docdir
         -- Try building docs first in case tests have an expected failure.
         when (buildDocs settings) $ do
             hfs <- readIORef haddockFilesRef
-            let hfsOpts = map ("--haddock-options=-o " ++) hfs
+            let hfsOpts = flip map hfs $ \(pkgVer, hf) -> concat
+                    [ "--haddock-options=--read-interface="
+                    , "../"
+                    , pkgVer
+                    , "/,"
+                    , hf
+                    ]
             getHandle AppendMode $ run "cabal"
                 ( "haddock"
                 : "--hyperlink-source"
@@ -159,7 +207,7 @@ runTestSuite cabalVersion settings testdir docdir
             case enewPath :: Either IOException FilePath of
                 Left e -> print e
                 Right newPath -> atomicModifyIORef haddockFilesRef $ \hfs'
-                    -> (newPath : hfs', ())
+                    -> ((package, newPath) : hfs', ())
 
         when spiHasTests $ do
             getHandle AppendMode $ run "cabal" ["build"] dir