@@ -10,6 +10,8 @@ import Control.Exception (Exception, SomeException, handle, throwIO,
1010import Control.Monad (replicateM, unless, when, forM_)
1111import qualified Data.Map as Map
1212import qualified Data.Set as Set
13+import qualified Control.Monad.Trans.Writer as W
14+import Distribution.Package (Dependency (Dependency))
1315import Data.Version (parseVersion, Version (Version))
1416import Data.Typeable (Typeable)
1517import Stackage.Types
@@ -22,17 +24,19 @@ import System.Exit (ExitCode (ExitSuccess))
2224import System.FilePath ((<.>), (</>), takeDirectory)
2325import System.IO (IOMode (WriteMode, AppendMode),
2426 withBinaryFile)
25−import System.Process (readProcess, runProcess, waitForProcess)
27+import System.Process (readProcess, runProcess, waitForProcess, createProcess, proc, cwd)
2628import Text.ParserCombinators.ReadP (readP_to_S)
2729import Data.IORef (IORef, readIORef, atomicModifyIORef, newIORef)
30+import qualified Data.ByteString.Lazy as L
31+import qualified Data.ByteString.Lazy.Char8 as L8
32+import qualified Distribution.PackageDescription as PD
33+import Distribution.PackageDescription.Parse (ParseResult (ParseOk),
34+ parsePackageDescription)
2835
2936runTestSuites :: BuildSettings -> BuildPlan -> IO ()
3037runTestSuites settings' bp = do
3138 settings <- fixBuildSettings settings'
3239 let selected' = Map.filterWithKey notSkipped $ bpPackages bp
33− putStrLn "Determining package dependencies"
34− selected <- mapM (addDependencies settings) $ Map.toList selected'
35− putStrLn "Running test suites"
3640 let testdir = "runtests"
3741 docdir = "haddock"
3842 rm_r testdir
@@ -40,6 +44,11 @@ runTestSuites settings' bp = do
4044 createDirectory testdir
4145 createDirectory docdir
4246
47+ putStrLn "Determining package dependencies"
48+ selected <- mapM (addDependencies settings (Map.keysSet selected') testdir)
49+ $ Map.toList selected'
50+ putStrLn "Running test suites"
51+
4352 copyBuiltInHaddocks docdir
4453
4554 cabalVersion <- getCabalVersion
@@ -55,19 +64,42 @@ runTestSuites settings' bp = do
5564 notSkipped p _ = p `Set.notMember` bpSkippedTests bp
5665
5766addDependencies :: BuildSettings
67+ -> Set PackageName -- ^ all packages to be installed
68+ -> FilePath -- ^ testdir
5869 -> (PackageName, SelectedPackageInfo)
5970 -> IO (PackageName, Set PackageName, SelectedPackageInfo)
60−addDependencies settings (packageName, spi) = do
71+addDependencies settings allPackages testdir (packageName, spi) = do
6172 package' <- replaceTarball (tarballDir settings) package
6273 deps <- handle (\e -> print (e :: IOException) >> return Set.empty)
63− $ getDeps package'
64− return (packageName, Set.empty, spi) -- FIXME
74+ $ getDeps allPackages testdir packageName package package'
75+ print (packageName, deps, spi)
76+ return (packageName, deps, spi)
6577 where
6678 package = packageVersionString (packageName, spiVersion spi)
6779
68−getDeps :: String -> IO (Set PackageName)
69−getDeps name = do
70− return Set.empty -- FIXME
80+getDeps :: Set PackageName -- ^ all packages to be installed
81+ -> FilePath -> PackageName -> String -> String -> IO (Set PackageName)
82+getDeps allPackages testdir (PackageName name) nameVer loc = do
83+ (Nothing, Nothing, Nothing, ph) <- createProcess
84+ (proc "cabal" ["unpack", loc, "--verbose=0"]) { cwd = Just testdir }
85+ ec <- waitForProcess ph
86+ unless (ec == ExitSuccess) $ error $ "Unable to unpack: " ++ loc
87+ lbs <- L.readFile $ testdir </> nameVer </> name <.> "cabal"
88+ case parsePackageDescription $ L8.unpack lbs of
89+ ParseOk _ gpd -> return $ Set.intersection allPackages $ allLibraryDeps gpd
90+ _ -> return Set.empty
91+
92+allLibraryDeps :: PD.GenericPackageDescription -> Set PackageName
93+allLibraryDeps =
94+ maybe Set.empty (W.execWriter . goTree) . PD.condLibrary
95+ where
96+ goTree tree = do
97+ mapM_ goDep $ PD.condTreeConstraints tree
98+ forM_ (PD.condTreeComponents tree) $ \(_, y, z) -> do
99+ goTree y
100+ maybe (return ()) goTree z
101+
102+ goDep (Dependency pn _) = W.tell $ Set.singleton pn
71103
72104getCabalVersion :: IO CabalVersion
73105getCabalVersion = do
@@ -168,8 +200,6 @@ runTestSuite cabalVersion settings testdir docdir
168200 unless (ec == ExitSuccess) $ throwIO TestException
169201
170202 passed <- handle (\TestException -> return False) $ do
171− package' <- replaceTarball (tarballDir settings) package
172− getHandle WriteMode $ run "cabal" ["unpack", package'] testdir
173203 case cabalFileDir settings of
174204 Nothing -> return ()
175205 Just cfd -> do
@@ -179,7 +209,7 @@ runTestSuite cabalVersion settings testdir docdir
179209 dst = cfd </> basename
180210 createDirectoryIfMissing True cfd
181211 copyFile src dst
182− getHandle AppendMode $ run "cabal" (addCabalArgs settings BSTest ["configure", "--enable-tests"]) dir
212+ getHandle WriteMode $ run "cabal" (addCabalArgs settings BSTest ["configure", "--enable-tests"]) dir
183213
184214 -- Try building docs first in case tests have an expected failure.
185215 when (buildDocs settings) $ do