Run tests in parallel (#4)

Stackage/Build.hs

@@ -39,6 +39,7 @@ defaultBuildSettings = BuildSettings
     , requireHaskellPlatform = True
     , cleanBeforeBuild = True
     , excludedPackages = empty
+    , testWorkerThreads = 4
     }
 
 build :: BuildSettings -> IO ()

Stackage/Test.hs

@@ -3,8 +3,9 @@ module Stackage.Test
     ( runTestSuites
     ) where
 
-import           Control.Exception  (Exception, handle, throwIO)
+import qualified Control.Concurrent as C
-import           Control.Monad      (foldM, unless, when)
+import           Control.Exception  (Exception, handle, throwIO, finally, SomeException)
+import           Control.Monad      (foldM, unless, when, replicateM)
 import qualified Data.Map           as Map
 import qualified Data.Set           as Set
 import           Data.Typeable      (Typeable)
@@ -25,13 +26,53 @@ runTestSuites settings ii = do
     let testdir = "runtests"
     rm_r testdir
     createDirectory testdir
-    allPass <- foldM (runTestSuite settings testdir hasTestSuites) True $ Map.toList $ iiPackages ii
+    allPass <- parFoldM (testWorkerThreads settings) (runTestSuite settings testdir hasTestSuites) (&&) True $ Map.toList $ iiPackages ii
     unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
   where
     PackageDB pdb = iiPackageDB ii
 
     hasTestSuites name = maybe defaultHasTestSuites piHasTests $ Map.lookup name pdb
 
+parFoldM :: Int -- ^ number of threads
+         -> (b -> IO c)
+         -> (a -> c -> a)
+         -> a
+         -> [b]
+         -> IO a
+parFoldM threadCount f g a0 bs0 = do
+    ma <- C.newMVar a0
+    mbs <- C.newMVar bs0
+    signal <- C.newEmptyMVar
+    tids <- replicateM threadCount $ C.forkIO $ worker ma mbs signal
+    wait threadCount signal tids
+    C.takeMVar ma
+  where
+    worker 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)
+            case mb of
+                Nothing -> return ()
+                Just b -> do
+                    c <- f b
+                    C.modifyMVar_ ma $ \a -> return $! g a c
+                    loop
+    wait threadCount signal tids
+        | threadCount == 0 = return ()
+        | otherwise = do
+            me <- C.takeMVar signal
+            case me of
+                Nothing -> wait (threadCount - 1) signal tids
+                Just e -> do
+                    mapM_ C.killThread tids
+                    throwIO (e :: SomeException)
+
 data TestException = TestException
     deriving (Show, Typeable)
 instance Exception TestException
@@ -39,10 +80,9 @@ instance Exception TestException
 runTestSuite :: BuildSettings
              -> FilePath
              -> (PackageName -> Bool) -- ^ do we have any test suites?
-             -> Bool
              -> (PackageName, (Version, Maintainer))
              -> IO Bool
-runTestSuite settings testdir hasTestSuites prevPassed (packageName, (version, Maintainer maintainer)) = do
+runTestSuite settings testdir hasTestSuites (packageName, (version, Maintainer maintainer)) = do
     -- Set up a new environment that includes the sandboxed bin folder in PATH.
     env' <- getModifiedEnv settings
     let menv addGPP
@@ -73,7 +113,7 @@ runTestSuite settings testdir hasTestSuites prevPassed (packageName, (version, M
             when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
         else unless expectedFailure $ putStrLn $ "Test suite failed: " ++ package ++ "(" ++ maintainer ++ ")"
     rm_r dir
-    return $! prevPassed && (passed || expectedFailure)
+    return $! passed || expectedFailure
   where
     logfile = testdir </> package <.> "log"
     dir = testdir </> package

Stackage/Types.hs

@@ -77,4 +77,6 @@ data BuildSettings = BuildSettings
     -- ^ Packages which should be dropped from the list of stable packages,
     -- even if present via the Haskell Platform or @stablePackages@. If these
     -- packages are dependencies of others, they will still be included.
+    , testWorkerThreads      :: Int
+    -- ^ How many threads to spawn for running test suites.
     }