@@ -29,7 +29,9 @@ import Data.IORef (IORef, readIORef, atomicModifyIORef, newIORef)
2929runTestSuites :: BuildSettings -> BuildPlan -> IO ()
3030runTestSuites settings' bp = do
3131 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'
3335 putStrLn "Running test suites"
3436 let testdir = "runtests"
3537 docdir = "haddock"
@@ -42,11 +44,31 @@ runTestSuites settings' bp = do
4244
4345 cabalVersion <- getCabalVersion
4446 haddockFilesRef <- newIORef []
45− allPass <- parFoldM (testWorkerThreads settings) (runTestSuite cabalVersion settings testdir docdir bp haddockFilesRef) (&&) True $ Map.toList selected
47+ allPass <- parFoldM
48+ (testWorkerThreads settings)
49+ (runTestSuite cabalVersion settings testdir docdir bp haddockFilesRef)
50+ (&&)
51+ True
52+ selected
4653 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
4754 where
4855 notSkipped p _ = p `Set.notMember` bpSkippedTests bp
4956
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+
5072getCabalVersion :: IO CabalVersion
5173getCabalVersion = do
5274 output <- readProcess "cabal" ["--numeric-version"] ""
@@ -58,35 +80,42 @@ getCabalVersion = do
5880 notCRLF '\r' = False
5981 notCRLF _ = True
6082
61−parFoldM :: Int -- ^ number of threads
62− -> (b -> IO c)
83+parFoldM :: (Ord key, Show key)
84+ => Int -- ^ number of threads
85+ -> ((key, payload) -> IO c)
6386 -> (a -> c -> a)
6487 -> a
65− -> [b]
88+ -> [(key, Set key, payload)]
6689 -> IO a
6790parFoldM threadCount0 f g a0 bs0 = do
6891 ma <- C.newMVar a0
6992 mbs <- C.newMVar bs0
7093 signal <- C.newEmptyMVar
71− tids <- replicateM threadCount0 $ C.forkIO $ worker ma mbs signal
94+ completed <- newIORef Set.empty
95+ tids <- replicateM threadCount0 $ C.forkIO $ worker completed ma mbs signal
7296 wait threadCount0 signal tids
97+ [] <- C.takeMVar mbs -- ensure all tests were run
7398 C.takeMVar ma
7499 where
75− worker ma mbs signal =
100+ worker completedRef ma mbs signal =
76101 handle
77102 (C.putMVar signal . Just)
78103 (loop >> C.putMVar signal Nothing)
79104 where
80105 loop = do
81− mb <- C.modifyMVar mbs $ \bs -> return $
82− case bs of
83− [] -> ([], Nothing)
84− b:bs' -> (bs', Just b)
106+ mb <- C.modifyMVar mbs $ \bs -> do
107+ completed <- readIORef completedRef
108+ return $ case findReady completed bs of
109+ -- There's a workload ready with no deps
110+ Just (b, bs') -> (bs', Just b)
111+ -- No workload with no deps
112+ Nothing -> (bs, Nothing)
85113 case mb of
86114 Nothing -> return ()
87− Just b -> do
88− c <- f b
115+ Just (name, _, payload) -> do
116+ c <- f (name, payload)
89117 C.modifyMVar_ ma $ \a -> return $! g a c
118+ atomicModifyIORef completedRef $ \s -> (Set.insert name s, ())
90119 loop
91120 wait threadCount signal tids
92121 | threadCount == 0 = return ()
@@ -98,6 +127,19 @@ parFoldM threadCount0 f g a0 bs0 = do
98127 mapM_ C.killThread tids
99128 throwIO (e :: SomeException)
100129
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+
101143data TestException = TestException
102144 deriving (Show, Typeable)
103145instance Exception TestException
@@ -110,7 +152,7 @@ runTestSuite :: CabalVersion
110152 -> FilePath -- ^ testdir
111153 -> FilePath -- ^ docdir
112154 -> BuildPlan
113− -> IORef [FilePath] -- ^ .haddock files
155+ -> IORef [(String, FilePath)] -- ^ .haddock files
114156 -> (PackageName, SelectedPackageInfo)
115157 -> IO Bool
116158runTestSuite cabalVersion settings testdir docdir
@@ -142,7 +184,13 @@ runTestSuite cabalVersion settings testdir docdir
142184 -- Try building docs first in case tests have an expected failure.
143185 when (buildDocs settings) $ do
144186 hfs <- readIORef haddockFilesRef
145− let hfsOpts = map ("--haddock-options=-o " ++) hfs
187+ let hfsOpts = flip map hfs $ \(pkgVer, hf) -> concat
188+ [ "--haddock-options=--read-interface="
189+ , "../"
190+ , pkgVer
191+ , "/,"
192+ , hf
193+ ]
146194 getHandle AppendMode $ run "cabal"
147195 ( "haddock"
148196 : "--hyperlink-source"
@@ -159,7 +207,7 @@ runTestSuite cabalVersion settings testdir docdir
159207 case enewPath :: Either IOException FilePath of
160208 Left e -> print e
161209 Right newPath -> atomicModifyIORef haddockFilesRef $ \hfs'
162− -> (newPath : hfs', ())
210+ -> ((package, newPath) : hfs', ())
163211
164212 when spiHasTests $ do
165213 getHandle AppendMode $ run "cabal" ["build"] dir