@@ -3,8 +3,9 @@ module Stackage.Test
33 ( runTestSuites
44 ) where
55
6−import Control.Exception (Exception, handle, throwIO)
7−import Control.Monad (foldM, unless, when)
6+import qualified Control.Concurrent as C
7+import Control.Exception (Exception, handle, throwIO, finally, SomeException)
8+import Control.Monad (foldM, unless, when, replicateM)
89import qualified Data.Map as Map
910import qualified Data.Set as Set
1011import Data.Typeable (Typeable)
@@ -25,13 +26,53 @@ runTestSuites settings ii = do
2526 let testdir = "runtests"
2627 rm_r testdir
2728 createDirectory testdir
28− allPass <- foldM (runTestSuite settings testdir hasTestSuites) True $ Map.toList $ iiPackages ii
29+ allPass <- parFoldM (testWorkerThreads settings) (runTestSuite settings testdir hasTestSuites) (&&) True $ Map.toList $ iiPackages ii
2930 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
3031 where
3132 PackageDB pdb = iiPackageDB ii
3233
3334 hasTestSuites name = maybe defaultHasTestSuites piHasTests $ Map.lookup name pdb
3435
36+parFoldM :: Int -- ^ number of threads
37+ -> (b -> IO c)
38+ -> (a -> c -> a)
39+ -> a
40+ -> [b]
41+ -> IO a
42+parFoldM threadCount f g a0 bs0 = do
43+ ma <- C.newMVar a0
44+ mbs <- C.newMVar bs0
45+ signal <- C.newEmptyMVar
46+ tids <- replicateM threadCount $ C.forkIO $ worker ma mbs signal
47+ wait threadCount signal tids
48+ C.takeMVar ma
49+ where
50+ worker ma mbs signal =
51+ handle
52+ (C.putMVar signal . Just)
53+ (loop >> C.putMVar signal Nothing)
54+ where
55+ loop = do
56+ mb <- C.modifyMVar mbs $ \bs -> return $
57+ case bs of
58+ [] -> ([], Nothing)
59+ b:bs' -> (bs', Just b)
60+ case mb of
61+ Nothing -> return ()
62+ Just b -> do
63+ c <- f b
64+ C.modifyMVar_ ma $ \a -> return $! g a c
65+ loop
66+ wait threadCount signal tids
67+ | threadCount == 0 = return ()
68+ | otherwise = do
69+ me <- C.takeMVar signal
70+ case me of
71+ Nothing -> wait (threadCount - 1) signal tids
72+ Just e -> do
73+ mapM_ C.killThread tids
74+ throwIO (e :: SomeException)
75+
3576data TestException = TestException
3677 deriving (Show, Typeable)
3778instance Exception TestException
@@ -39,10 +80,9 @@ instance Exception TestException
3980runTestSuite :: BuildSettings
4081 -> FilePath
4182 -> (PackageName -> Bool) -- ^ do we have any test suites?
42− -> Bool
4383 -> (PackageName, (Version, Maintainer))
4484 -> IO Bool
45−runTestSuite settings testdir hasTestSuites prevPassed (packageName, (version, Maintainer maintainer)) = do
85+runTestSuite settings testdir hasTestSuites (packageName, (version, Maintainer maintainer)) = do
4686 -- Set up a new environment that includes the sandboxed bin folder in PATH.
4787 env' <- getModifiedEnv settings
4888 let menv addGPP
@@ -73,7 +113,7 @@ runTestSuite settings testdir hasTestSuites prevPassed (packageName, (version, M
73113 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
74114 else unless expectedFailure $ putStrLn $ "Test suite failed: " ++ package ++ "(" ++ maintainer ++ ")"
75115 rm_r dir
76− return $! prevPassed && (passed || expectedFailure)
116+ return $! passed || expectedFailure
77117 where
78118 logfile = testdir </> package <.> "log"
79119 dir = testdir </> package