@@ -10,6 +10,8 @@ import Control.Exception (Exception, SomeException, handle, throwIO,
10import Control.Monad (replicateM, unless, when, forM_)
10import Control.Monad (replicateM, unless, when, forM_)
11import qualified Data.Map as Map
11import qualified Data.Map as Map
12import qualified Data.Set as Set
12import qualified Data.Set as Set
13+import qualified Control.Monad.Trans.Writer as W
14+import Distribution.Package (Dependency (Dependency))
13import Data.Version (parseVersion, Version (Version))
15import Data.Version (parseVersion, Version (Version))
14import Data.Typeable (Typeable)
16import Data.Typeable (Typeable)
15import Stackage.Types
17import Stackage.Types
@@ -22,17 +24,19 @@ import System.Exit (ExitCode (ExitSuccess))
22import System.FilePath ((<.>), (</>), takeDirectory)
24import System.FilePath ((<.>), (</>), takeDirectory)
23import System.IO (IOMode (WriteMode, AppendMode),
25import System.IO (IOMode (WriteMode, AppendMode),
24 withBinaryFile)
26 withBinaryFile)
25−import System.Process (readProcess, runProcess, waitForProcess)
27+import System.Process (readProcess, runProcess, waitForProcess, createProcess, proc, cwd)
26import Text.ParserCombinators.ReadP (readP_to_S)
28import Text.ParserCombinators.ReadP (readP_to_S)
27import Data.IORef (IORef, readIORef, atomicModifyIORef, newIORef)
29import 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)
29runTestSuites :: BuildSettings -> BuildPlan -> IO ()
36runTestSuites :: BuildSettings -> BuildPlan -> IO ()
30runTestSuites settings' bp = do
37runTestSuites settings' bp = do
31 settings <- fixBuildSettings settings'
38 settings <- fixBuildSettings settings'
32 let selected' = Map.filterWithKey notSkipped $ bpPackages bp
39 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"
36 let testdir = "runtests"
40 let testdir = "runtests"
37 docdir = "haddock"
41 docdir = "haddock"
38 rm_r testdir
42 rm_r testdir
@@ -40,6 +44,11 @@ runTestSuites settings' bp = do
40 createDirectory testdir
44 createDirectory testdir
41 createDirectory docdir
45 createDirectory docdir
47+ putStrLn "Determining package dependencies"
48+ selected <- mapM (addDependencies settings (Map.keysSet selected') testdir)
49+ $ Map.toList selected'
50+ putStrLn "Running test suites"
43 copyBuiltInHaddocks docdir
52 copyBuiltInHaddocks docdir
45 cabalVersion <- getCabalVersion
54 cabalVersion <- getCabalVersion
@@ -55,19 +64,42 @@ runTestSuites settings' bp = do
55 notSkipped p _ = p `Set.notMember` bpSkippedTests bp
64 notSkipped p _ = p `Set.notMember` bpSkippedTests bp
57addDependencies :: BuildSettings
66addDependencies :: BuildSettings
67+ -> Set PackageName -- ^ all packages to be installed
68+ -> FilePath -- ^ testdir
58 -> (PackageName, SelectedPackageInfo)
69 -> (PackageName, SelectedPackageInfo)
59 -> IO (PackageName, Set PackageName, SelectedPackageInfo)
70 -> IO (PackageName, Set PackageName, SelectedPackageInfo)
60−addDependencies settings (packageName, spi) = do
71+addDependencies settings allPackages testdir (packageName, spi) = do
61 package' <- replaceTarball (tarballDir settings) package
72 package' <- replaceTarball (tarballDir settings) package
62 deps <- handle (\e -> print (e :: IOException) >> return Set.empty)
73 deps <- handle (\e -> print (e :: IOException) >> return Set.empty)
63− $ getDeps package'
74+ $ getDeps allPackages testdir packageName package package'
75+ print (packageName, deps, spi)
64− return (packageName, Set.empty, spi) -- FIXME
76+ return (packageName, deps, spi)
66 package = packageVersionString (packageName, spiVersion spi)
78 package = packageVersionString (packageName, spiVersion spi)
80+getDeps :: Set PackageName -- ^ all packages to be installed
68−getDeps :: String -> IO (Set PackageName)
81+ -> FilePath -> PackageName -> String -> String -> IO (Set PackageName)
69−getDeps name = do
82+getDeps allPackages testdir (PackageName name) nameVer loc = do
70− return Set.empty -- FIXME
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
92+allLibraryDeps :: PD.GenericPackageDescription -> Set PackageName
94+ maybe Set.empty (W.execWriter . goTree) . PD.condLibrary
97+ mapM_ goDep $ PD.condTreeConstraints tree
98+ forM_ (PD.condTreeComponents tree) $ \(_, y, z) -> do
100+ maybe (return ()) goTree z
102+ goDep (Dependency pn _) = W.tell $ Set.singleton pn
72getCabalVersion :: IO CabalVersion
104getCabalVersion :: IO CabalVersion
73getCabalVersion = do
105getCabalVersion = do
@@ -168,8 +200,6 @@ runTestSuite cabalVersion settings testdir docdir
168 unless (ec == ExitSuccess) $ throwIO TestException
200 unless (ec == ExitSuccess) $ throwIO TestException
170 passed <- handle (\TestException -> return False) $ do
202 passed <- handle (\TestException -> return False) $ do
171− package' <- replaceTarball (tarballDir settings) package
172− getHandle WriteMode $ run "cabal" ["unpack", package'] testdir
173 case cabalFileDir settings of
203 case cabalFileDir settings of
174 Nothing -> return ()
204 Nothing -> return ()
175 Just cfd -> do
205 Just cfd -> do
@@ -179,7 +209,7 @@ runTestSuite cabalVersion settings testdir docdir
179 dst = cfd </> basename
209 dst = cfd </> basename
180 createDirectoryIfMissing True cfd
210 createDirectoryIfMissing True cfd
181 copyFile src dst
211 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
184 -- Try building docs first in case tests have an expected failure.
214 -- Try building docs first in case tests have an expected failure.
185 when (buildDocs settings) $ do
215 when (buildDocs settings) $ do