git.iko.soy/stackage
on master help sign in
Run tests in parallel (#4)
bb7e35eMichael Snoyman
Stackage/Build.hs+1
compare with master
unifiedsplit
@@ -39,6 +39,7 @@ defaultBuildSettings = BuildSettings
39 , requireHaskellPlatform = True
39 , requireHaskellPlatform = True
40 , cleanBeforeBuild = True
40 , cleanBeforeBuild = True
41 , excludedPackages = empty
41 , excludedPackages = empty
42+ , testWorkerThreads = 4
42 }
43 }
43
44
44build :: BuildSettings -> IO ()
45build :: BuildSettings -> IO ()
Stackage/Test.hs+46−6
@@ -3,8 +3,9 @@ module Stackage.Test
3 ( runTestSuites
3 ( runTestSuites
4 ) where
4 ) where
5
5
6+import qualified Control.Concurrent as C
6−import Control.Exception (Exception, handle, throwIO)
7+import Control.Exception (Exception, handle, throwIO, finally, SomeException)
7−import Control.Monad (foldM, unless, when)
8+import Control.Monad (foldM, unless, when, replicateM)
8import qualified Data.Map as Map
9import qualified Data.Map as Map
9import qualified Data.Set as Set
10import qualified Data.Set as Set
10import Data.Typeable (Typeable)
11import Data.Typeable (Typeable)
@@ -25,13 +26,53 @@ runTestSuites settings ii = do
25 let testdir = "runtests"
26 let testdir = "runtests"
26 rm_r testdir
27 rm_r testdir
27 createDirectory testdir
28 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
29 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
30 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
30 where
31 where
31 PackageDB pdb = iiPackageDB ii
32 PackageDB pdb = iiPackageDB ii
32
33
33 hasTestSuites name = maybe defaultHasTestSuites piHasTests $ Map.lookup name pdb
34 hasTestSuites name = maybe defaultHasTestSuites piHasTests $ Map.lookup name pdb
34
35
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+
35data TestException = TestException
76data TestException = TestException
36 deriving (Show, Typeable)
77 deriving (Show, Typeable)
37instance Exception TestException
78instance Exception TestException
@@ -39,10 +80,9 @@ instance Exception TestException
39runTestSuite :: BuildSettings
80runTestSuite :: BuildSettings
40 -> FilePath
81 -> FilePath
41 -> (PackageName -> Bool) -- ^ do we have any test suites?
82 -> (PackageName -> Bool) -- ^ do we have any test suites?
42− -> Bool
43 -> (PackageName, (Version, Maintainer))
83 -> (PackageName, (Version, Maintainer))
44 -> IO Bool
84 -> IO Bool
45−runTestSuite settings testdir hasTestSuites prevPassed (packageName, (version, Maintainer maintainer)) = do
85+runTestSuite settings testdir hasTestSuites (packageName, (version, Maintainer maintainer)) = do
46 -- Set up a new environment that includes the sandboxed bin folder in PATH.
86 -- Set up a new environment that includes the sandboxed bin folder in PATH.
47 env' <- getModifiedEnv settings
87 env' <- getModifiedEnv settings
48 let menv addGPP
88 let menv addGPP
@@ -73,7 +113,7 @@ runTestSuite settings testdir hasTestSuites prevPassed (packageName, (version, M
73 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
113 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
74 else unless expectedFailure $ putStrLn $ "Test suite failed: " ++ package ++ "(" ++ maintainer ++ ")"
114 else unless expectedFailure $ putStrLn $ "Test suite failed: " ++ package ++ "(" ++ maintainer ++ ")"
75 rm_r dir
115 rm_r dir
76− return $! prevPassed && (passed || expectedFailure)
116+ return $! passed || expectedFailure
77 where
117 where
78 logfile = testdir </> package <.> "log"
118 logfile = testdir </> package <.> "log"
79 dir = testdir </> package
119 dir = testdir </> package
Stackage/Types.hs+2
@@ -77,4 +77,6 @@ data BuildSettings = BuildSettings
77 -- ^ Packages which should be dropped from the list of stable packages,
77 -- ^ Packages which should be dropped from the list of stable packages,
78 -- even if present via the Haskell Platform or @stablePackages@. If these
78 -- even if present via the Haskell Platform or @stablePackages@. If these
79 -- packages are dependencies of others, they will still be included.
79 -- packages are dependencies of others, they will still be included.
80+ , testWorkerThreads :: Int
81+ -- ^ How many threads to spawn for running test suites.
80 }
82 }