git.iko.soy/stackage
on master help sign in
Most of the work on topological sorting of tests
d150d66Michael Snoyman
Stackage/Test.hs+64−16
compare with master
unifiedsplit
@@ -29,7 +29,9 @@ import Data.IORef (IORef, readIORef, atomicModifyIORef, newIORef)
29runTestSuites :: BuildSettings -> BuildPlan -> IO ()
29runTestSuites :: BuildSettings -> BuildPlan -> IO ()
30runTestSuites settings' bp = do
30runTestSuites settings' bp = do
31 settings <- fixBuildSettings settings'
31 settings <- fixBuildSettings settings'
32− let selected = Map.filterWithKey notSkipped $ bpPackages bp
32+ let selected' = Map.filterWithKey notSkipped $ bpPackages bp
33+ putStrLn "Determining package dependencies"
34+ selected <- mapM (addDependencies settings) $ Map.toList selected'
33 putStrLn "Running test suites"
35 putStrLn "Running test suites"
34 let testdir = "runtests"
36 let testdir = "runtests"
35 docdir = "haddock"
37 docdir = "haddock"
@@ -42,11 +44,31 @@ runTestSuites settings' bp = do
42
44
43 cabalVersion <- getCabalVersion
45 cabalVersion <- getCabalVersion
44 haddockFilesRef <- newIORef []
46 haddockFilesRef <- newIORef []
47+ allPass <- parFoldM
48+ (testWorkerThreads settings)
45− allPass <- parFoldM (testWorkerThreads settings) (runTestSuite cabalVersion settings testdir docdir bp haddockFilesRef) (&&) True $ Map.toList selected
49+ (runTestSuite cabalVersion settings testdir docdir bp haddockFilesRef)
50+ (&&)
51+ True
52+ selected
46 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
53 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
47 where
54 where
48 notSkipped p _ = p `Set.notMember` bpSkippedTests bp
55 notSkipped p _ = p `Set.notMember` bpSkippedTests bp
49
56
57+addDependencies :: BuildSettings
58+ -> (PackageName, SelectedPackageInfo)
59+ -> IO (PackageName, Set PackageName, SelectedPackageInfo)
60+addDependencies settings (packageName, spi) = do
61+ package' <- replaceTarball (tarballDir settings) package
62+ deps <- handle (\e -> print (e :: IOException) >> return Set.empty)
63+ $ getDeps package'
64+ return (packageName, Set.empty, spi) -- FIXME
65+ where
66+ package = packageVersionString (packageName, spiVersion spi)
67+
68+getDeps :: String -> IO (Set PackageName)
69+getDeps name = do
70+ return Set.empty -- FIXME
71+
50getCabalVersion :: IO CabalVersion
72getCabalVersion :: IO CabalVersion
51getCabalVersion = do
73getCabalVersion = do
52 output <- readProcess "cabal" ["--numeric-version"] ""
74 output <- readProcess "cabal" ["--numeric-version"] ""
@@ -58,35 +80,42 @@ getCabalVersion = do
58 notCRLF '\r' = False
80 notCRLF '\r' = False
59 notCRLF _ = True
81 notCRLF _ = True
60
82
83+parFoldM :: (Ord key, Show key)
61−parFoldM :: Int -- ^ number of threads
84+ => Int -- ^ number of threads
62− -> (b -> IO c)
85+ -> ((key, payload) -> IO c)
63 -> (a -> c -> a)
86 -> (a -> c -> a)
64 -> a
87 -> a
65− -> [b]
88+ -> [(key, Set key, payload)]
66 -> IO a
89 -> IO a
67parFoldM threadCount0 f g a0 bs0 = do
90parFoldM threadCount0 f g a0 bs0 = do
68 ma <- C.newMVar a0
91 ma <- C.newMVar a0
69 mbs <- C.newMVar bs0
92 mbs <- C.newMVar bs0
70 signal <- C.newEmptyMVar
93 signal <- C.newEmptyMVar
94+ completed <- newIORef Set.empty
71− tids <- replicateM threadCount0 $ C.forkIO $ worker ma mbs signal
95+ tids <- replicateM threadCount0 $ C.forkIO $ worker completed ma mbs signal
72 wait threadCount0 signal tids
96 wait threadCount0 signal tids
97+ [] <- C.takeMVar mbs -- ensure all tests were run
73 C.takeMVar ma
98 C.takeMVar ma
74 where
99 where
75− worker ma mbs signal =
100+ worker completedRef ma mbs signal =
76 handle
101 handle
77 (C.putMVar signal . Just)
102 (C.putMVar signal . Just)
78 (loop >> C.putMVar signal Nothing)
103 (loop >> C.putMVar signal Nothing)
79 where
104 where
80 loop = do
105 loop = do
81− mb <- C.modifyMVar mbs $ \bs -> return $
106+ mb <- C.modifyMVar mbs $ \bs -> do
107+ completed <- readIORef completedRef
82− case bs of
108+ return $ case findReady completed bs of
83− [] -> ([], Nothing)
109+ -- There's a workload ready with no deps
84− b:bs' -> (bs', Just b)
110+ Just (b, bs') -> (bs', Just b)
111+ -- No workload with no deps
112+ Nothing -> (bs, Nothing)
85 case mb of
113 case mb of
86 Nothing -> return ()
114 Nothing -> return ()
87− Just b -> do
115+ Just (name, _, payload) -> do
88− c <- f b
116+ c <- f (name, payload)
89 C.modifyMVar_ ma $ \a -> return $! g a c
117 C.modifyMVar_ ma $ \a -> return $! g a c
118+ atomicModifyIORef completedRef $ \s -> (Set.insert name s, ())
90 loop
119 loop
91 wait threadCount signal tids
120 wait threadCount signal tids
92 | threadCount == 0 = return ()
121 | threadCount == 0 = return ()
@@ -98,6 +127,19 @@ parFoldM threadCount0 f g a0 bs0 = do
98 mapM_ C.killThread tids
127 mapM_ C.killThread tids
99 throwIO (e :: SomeException)
128 throwIO (e :: SomeException)
100
129
130+-- | Find a workload whose dependencies have been met.
131+findReady :: Ord key
132+ => Set key -- ^ workloads already complete
133+ -> [(key, Set key, value)]
134+ -> Maybe ((key, Set key, value), [(key, Set key, value)])
135+findReady completed =
136+ loop id
137+ where
138+ loop _ [] = Nothing
139+ loop front (x@(_, deps, _):xs)
140+ | Set.null $ Set.difference deps completed = Just (x, front xs)
141+ | otherwise = loop (front . (x:)) xs
142+
101data TestException = TestException
143data TestException = TestException
102 deriving (Show, Typeable)
144 deriving (Show, Typeable)
103instance Exception TestException
145instance Exception TestException
@@ -110,7 +152,7 @@ runTestSuite :: CabalVersion
110 -> FilePath -- ^ testdir
152 -> FilePath -- ^ testdir
111 -> FilePath -- ^ docdir
153 -> FilePath -- ^ docdir
112 -> BuildPlan
154 -> BuildPlan
113− -> IORef [FilePath] -- ^ .haddock files
155+ -> IORef [(String, FilePath)] -- ^ .haddock files
114 -> (PackageName, SelectedPackageInfo)
156 -> (PackageName, SelectedPackageInfo)
115 -> IO Bool
157 -> IO Bool
116runTestSuite cabalVersion settings testdir docdir
158runTestSuite cabalVersion settings testdir docdir
@@ -142,7 +184,13 @@ runTestSuite cabalVersion settings testdir docdir
142 -- Try building docs first in case tests have an expected failure.
184 -- Try building docs first in case tests have an expected failure.
143 when (buildDocs settings) $ do
185 when (buildDocs settings) $ do
144 hfs <- readIORef haddockFilesRef
186 hfs <- readIORef haddockFilesRef
187+ let hfsOpts = flip map hfs $ \(pkgVer, hf) -> concat
145− let hfsOpts = map ("--haddock-options=-o " ++) hfs
188+ [ "--haddock-options=--read-interface="
189+ , "../"
190+ , pkgVer
191+ , "/,"
192+ , hf
193+ ]
146 getHandle AppendMode $ run "cabal"
194 getHandle AppendMode $ run "cabal"
147 ( "haddock"
195 ( "haddock"
148 : "--hyperlink-source"
196 : "--hyperlink-source"
@@ -159,7 +207,7 @@ runTestSuite cabalVersion settings testdir docdir
159 case enewPath :: Either IOException FilePath of
207 case enewPath :: Either IOException FilePath of
160 Left e -> print e
208 Left e -> print e
161 Right newPath -> atomicModifyIORef haddockFilesRef $ \hfs'
209 Right newPath -> atomicModifyIORef haddockFilesRef $ \hfs'
162− -> (newPath : hfs', ())
210+ -> ((package, newPath) : hfs', ())
163
211
164 when spiHasTests $ do
212 when spiHasTests $ do
165 getHandle AppendMode $ run "cabal" ["build"] dir
213 getHandle AppendMode $ run "cabal" ["build"] dir