git.iko.soy/stackage
on master help sign in
Build plan created separately (partway to #25)
fb2385dMichael Snoyman
Stackage/Build.hs+22−39
compare with master
unifiedsplit
@@ -28,6 +28,8 @@ import System.IO (IOMode (WriteMode), hPutStrLn,
28 withBinaryFile)
28 withBinaryFile)
29import System.Process (rawSystem, readProcess, runProcess,
29import System.Process (rawSystem, readProcess, runProcess,
30 waitForProcess)
30 waitForProcess)
31+import Stackage.Select (select)
32+import Stackage.CheckCabalVersion (checkCabalVersion)
31
33
32defaultBuildSettings :: BuildSettings
34defaultBuildSettings :: BuildSettings
33defaultBuildSettings = BuildSettings
35defaultBuildSettings = BuildSettings
@@ -39,7 +41,6 @@ defaultBuildSettings = BuildSettings
39 , extraArgs = ["-fnetwork23"]
41 , extraArgs = ["-fnetwork23"]
40 , haskellPlatformCabal = "haskell-platform/haskell-platform.cabal"
42 , haskellPlatformCabal = "haskell-platform/haskell-platform.cabal"
41 , requireHaskellPlatform = True
43 , requireHaskellPlatform = True
42− , cleanBeforeBuild = True
43 , excludedPackages = empty
44 , excludedPackages = empty
44 , testWorkerThreads = 4
45 , testWorkerThreads = 4
45 , flags = Set.fromList $ words "blaze_html_0_5"
46 , flags = Set.fromList $ words "blaze_html_0_5"
@@ -48,49 +49,31 @@ defaultBuildSettings = BuildSettings
48
49
49build :: BuildSettings -> IO ()
50build :: BuildSettings -> IO ()
50build settings' = do
51build settings' = do
51− ii <- getInstallInfo settings'
52+ putStrLn "Checking Cabal version"
53+ libVersion <- checkCabalVersion
52
54
53− let root' = sandboxRoot settings'
55+ bp <- select settings'
54− initPkgDb <- if cleanBeforeBuild settings'
55− then do
56− putStrLn "Wiping out old sandbox folder"
57− rm_r root'
58− rm_r "logs"
59− return True
60− else do
61− b <- doesDirectoryExist root'
62− when b (putStrLn "Re-using existing sandbox")
63− return (not b)
64− createDirectoryIfMissing True root'
65− root <- canonicalizePath root'
66− let settings = settings' { sandboxRoot = root }
67
56
68− when initPkgDb $ do
57+ putStrLn "Checking build plan"
69− ec1 <- rawSystem "ghc-pkg" ["init", packageDir settings]
70− unless (ec1 == ExitSuccess) $ do
71− putStrLn "Unable to create package database via ghc-pkg init"
72− exitWith ec1
73− checkPlan settings ii
58+ checkPlan bp
74− putStrLn "No mismatches, starting the sandboxed build."
59+ putStrLn "No mismatches, starting the sandboxed build."
75
60
76− versionString <- readProcess "cabal" ["--version"] ""
61+ putStrLn "Wiping out old sandbox folder"
77− libVersion <-
62+ rm_r $ sandboxRoot settings'
78− case map words $ lines versionString of
63+ rm_r "logs"
79− [_,["using","version",libVersion,"of","the","Cabal","library"]] -> return libVersion
64+ settings <- fixBuildSettings settings'
80− _ -> error "Did not understand cabal --version output"
81
65
82− case (simpleParse libVersion, simpleParse ">= 1.16") of
66+ putStrLn "Creating new package database"
83− (Nothing, _) -> error $ "Invalid Cabal library version: " ++ libVersion
67+ ec1 <- rawSystem "ghc-pkg" ["init", packageDir settings]
84− (_, Nothing) -> assert False $ return ()
68+ unless (ec1 == ExitSuccess) $ do
85− (Just v, Just vr)
69+ putStrLn "Unable to create package database via ghc-pkg init"
86− | v `withinRange` vr -> return ()
70+ exitWith ec1
87− | otherwise -> error $ "Unsupported Cabal version: " ++ libVersion
88
71
89 menv <- fmap Just $ getModifiedEnv settings
72 menv <- fmap Just $ getModifiedEnv settings
90 let runCabal args handle = runProcess "cabal" args Nothing menv Nothing (Just handle) (Just handle)
73 let runCabal args handle = runProcess "cabal" args Nothing menv Nothing (Just handle) (Just handle)
91
74
92 -- First install build tools so they can be used below.
75 -- First install build tools so they can be used below.
93− case iiBuildTools ii of
76+ case bpTools bp of
94 [] -> putStrLn "No build tools required"
77 [] -> putStrLn "No build tools required"
95 tools -> do
78 tools -> do
96 putStrLn $ "Installing the following build tools: " ++ unwords tools
79 putStrLn $ "Installing the following build tools: " ++ unwords tools
@@ -103,7 +86,7 @@ build settings' = do
103 : concat
86 : concat
104 [ extraBuildArgs settings
87 [ extraBuildArgs settings
105 , extraArgs settings
88 , extraArgs settings
106− , iiBuildTools ii
89+ , tools
107 ]
90 ]
108 hPutStrLn handle ("cabal " ++ unwords (map (\s -> "'" ++ s ++ "'") args))
91 hPutStrLn handle ("cabal " ++ unwords (map (\s -> "'" ++ s ++ "'") args))
109 runCabal args handle
92 runCabal args handle
@@ -122,7 +105,7 @@ build settings' = do
122 : concat
105 : concat
123 [ extraBuildArgs settings
106 [ extraBuildArgs settings
124 , extraArgs settings
107 , extraArgs settings
125− , iiPackageList ii
108+ , bpPackageList bp
126 ]
109 ]
127 hPutStrLn handle ("cabal " ++ unwords (map (\s -> "'" ++ s ++ "'") args))
110 hPutStrLn handle ("cabal " ++ unwords (map (\s -> "'" ++ s ++ "'") args))
128 runCabal args handle
111 runCabal args handle
@@ -132,10 +115,10 @@ build settings' = do
132 exitWith ec
115 exitWith ec
133
116
134 putStrLn "Sandbox built, beginning individual test suites"
117 putStrLn "Sandbox built, beginning individual test suites"
135− runTestSuites settings ii
118+ runTestSuites settings $ bpPackages bp
136
119
137 putStrLn "All test suites that were expected to pass did pass, building tarballs."
120 putStrLn "All test suites that were expected to pass did pass, building tarballs."
138− makeTarballs ii
121+ makeTarballs bp
139
122
140-- | Get all of the build tools required.
123-- | Get all of the build tools required.
141iiBuildTools :: InstallInfo -> [String]
124iiBuildTools :: InstallInfo -> [String]
Stackage/BuildPlan.hsnew file+139
@@ -0,0 +1,139 @@
1+{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+module Stackage.BuildPlan
4+ ( readBuildPlan
5+ , writeBuildPlan
6+ ) where
7+
8+import Stackage.Types
9+import qualified Data.Map as Map
10+import qualified Data.Set as Set
11+import Distribution.Text (simpleParse, display)
12+import Distribution.Package (PackageName (..))
13+import Control.Applicative ((<$>), (<*>))
14+
15+readBuildPlan :: FilePath -> IO BuildPlan
16+readBuildPlan fp = do
17+ str <- readFile fp
18+ case fromString str of
19+ Left s -> error $ "Could not read build plan: " ++ s
20+ Right (x, "") -> return x
21+ Right (_, _:_) -> error "Trailing content when reading build plan"
22+
23+writeBuildPlan :: FilePath -> BuildPlan -> IO ()
24+writeBuildPlan fp bp = writeFile fp $ toString bp
25+
26+class AsString a where
27+ toString :: a -> String
28+ fromString :: String -> Either String (a, String)
29+
30+instance AsString BuildPlan where
31+ toString BuildPlan {..} = concat
32+ [ makeSection "tools" bpTools
33+ , makeSection "packages" $ Map.toList bpPackages
34+ , makeSection "core" $ Set.toList bpCore
35+ , makeSection "optional-core" $ Map.toList bpOptionalCore
36+ ]
37+ fromString s1 = do
38+ (tools, s2) <- getSection "tools" s1
39+ (packages, s3) <- getSection "packages" s2
40+ (core, s4) <- getSection "core" s3
41+ (optionalCore, s5) <- getSection "optional-core" s4
42+ let bp = BuildPlan
43+ { bpTools = tools
44+ , bpPackages = Map.fromList packages
45+ , bpCore = Set.fromList core
46+ , bpOptionalCore = Map.fromList optionalCore
47+ }
48+ return (bp, s5)
49+
50+makeSection :: AsString a => String -> [a] -> String
51+makeSection title contents = unlines
52+ $ ("-- BEGIN " ++ title)
53+ : map toString contents
54+ ++ ["-- END " ++ title, ""]
55+
56+instance AsString String where
57+ toString = id
58+ fromString s = Right (s, "")
59+
60+instance AsString PackageName where
61+ toString (PackageName pn) = pn
62+ fromString s = Right (PackageName s, "")
63+
64+instance AsString a => AsString (PackageName, a) where
65+ toString (PackageName pn, s) = concat [pn, " ", toString s]
66+ fromString s = do
67+ (pn, rest) <- takeWord s
68+ (rest', s') <- fromString rest
69+ return ((PackageName pn, rest'), s')
70+
71+takeWord :: AsString a => String -> Either String (a, String)
72+takeWord s =
73+ case break (== ' ') s of
74+ (x, _:y) -> do
75+ (x', s') <- fromString x
76+ if null s'
77+ then Right (x', y)
78+ else Left $ "Unconsumed input in takeWord call"
79+
80+instance AsString SelectedPackageInfo where
81+ toString SelectedPackageInfo {..} = unwords
82+ [ display spiVersion
83+ , toString spiHasTests
84+ , maybe "@" ("@" ++) spiGithubUser
85+ , unMaintainer spiMaintainer
86+ ]
87+ fromString s1 = do
88+ (version, s2) <- takeWord s1
89+ (hasTests, s3) <- takeWord s2
90+ (gu, m) <- takeWord s3
91+ Right (SelectedPackageInfo
92+ { spiVersion = version
93+ , spiHasTests = hasTests
94+ , spiGithubUser = gu
95+ , spiMaintainer = Maintainer m
96+ }, "")
97+
98+instance AsString (Maybe String) where
99+ toString Nothing = "@"
100+ toString (Just x) = "@" ++ x
101+ fromString "@" = Right (Nothing, "")
102+ fromString ('@':rest) = Right (Just rest, "")
103+ fromString x = Left $ "Invalid Github user: " ++ x
104+
105+instance AsString Bool where
106+ toString True = "test"
107+ toString False = "notest"
108+ fromString "test" = Right (True, "")
109+ fromString "notest" = Right (False, "")
110+ fromString x = Left $ "Invalid test value: " ++ x
111+
112+instance AsString Version where
113+ toString = display
114+ fromString s =
115+ case simpleParse s of
116+ Nothing -> Left $ "Invalid version: " ++ s
117+ Just v -> Right (v, "")
118+
119+getSection :: AsString a => String -> String -> Either String ([a], String)
120+getSection title orig =
121+ case lines orig of
122+ [] -> Left "Unexpected EOF when looking for a section"
123+ l1:ls1
124+ | l1 == begin ->
125+ case break (== end) ls1 of
126+ (here, _:"":rest) -> do
127+ here' <- mapM fromString' here
128+ Right (here', unlines rest)
129+ (_, _) -> Left $ "Could not find section end: " ++ title
130+ | otherwise -> Left $ "Could not find section start: " ++ title
131+ where
132+ begin = "-- BEGIN " ++ title
133+ end = "-- END " ++ title
134+
135+ fromString' x = do
136+ (y, z) <- fromString x
137+ if null z
138+ then return y
139+ else Left $ "Unconsumed input on line: " ++ x
Stackage/CheckCabalVersion.hsnew file+45
@@ -0,0 +1,45 @@
1+module Stackage.CheckCabalVersion
2+ ( checkCabalVersion
3+ ) where
4+
5+import Control.Exception (assert)
6+import Control.Monad (unless, when)
7+import qualified Data.Map as Map
8+import Data.Maybe (mapMaybe)
9+import Data.Set (empty)
10+import qualified Data.Set as Set
11+import Distribution.Text (simpleParse)
12+import Distribution.Version (withinRange)
13+import Prelude hiding (pi)
14+import Stackage.CheckPlan
15+import Stackage.Config
16+import Stackage.InstallInfo
17+import Stackage.Tarballs
18+import Stackage.Test
19+import Stackage.Types
20+import Stackage.Util
21+import System.Directory (canonicalizePath,
22+ createDirectoryIfMissing,
23+ doesDirectoryExist)
24+import System.Exit (ExitCode (ExitSuccess), exitWith)
25+import System.IO (IOMode (WriteMode), hPutStrLn,
26+ withBinaryFile)
27+import System.Process (rawSystem, readProcess, runProcess,
28+ waitForProcess)
29+
30+checkCabalVersion :: IO String
31+checkCabalVersion = do
32+ versionString <- readProcess "cabal" ["--version"] ""
33+ libVersion <-
34+ case map words $ lines versionString of
35+ [_,["using","version",libVersion,"of","the","Cabal","library"]] -> return libVersion
36+ _ -> error "Did not understand cabal --version output"
37+
38+ case (simpleParse libVersion, simpleParse ">= 1.16") of
39+ (Nothing, _) -> error $ "Invalid Cabal library version: " ++ libVersion
40+ (_, Nothing) -> assert False $ return ()
41+ (Just v, Just vr)
42+ | v `withinRange` vr -> return ()
43+ | otherwise -> error $ "Unsupported Cabal version: " ++ libVersion
44+
45+ return libVersion
Stackage/CheckPlan.hs+5−5
@@ -16,22 +16,22 @@ import System.Process (readProcessWithExitCode)
16data Mismatch = OnlyDryRun String | OnlySimpleList String
16data Mismatch = OnlyDryRun String | OnlySimpleList String
17 deriving Show
17 deriving Show
18
18
19−checkPlan :: BuildSettings -> InstallInfo -> IO ()
19+checkPlan :: BuildPlan -> IO ()
20−checkPlan settings ii = do
20+checkPlan bp = do
21− (ec, dryRun', stderr) <- readProcessWithExitCode "cabal" (addCabalArgs settings $ "install":"--dry-run":iiPackageList ii) ""
21+ (ec, dryRun', stderr) <- readProcessWithExitCode "cabal" (addCabalArgsOnlyGlobal $ "install":"--dry-run":bpPackageList bp) ""
22 when (ec /= ExitSuccess || "Warning:" `isPrefixOf` stderr) $ do
22 when (ec /= ExitSuccess || "Warning:" `isPrefixOf` stderr) $ do
23 putStr stderr
23 putStr stderr
24 putStr dryRun'
24 putStr dryRun'
25 putStrLn "cabal returned a bad result, exiting"
25 putStrLn "cabal returned a bad result, exiting"
26 exitWith ec
26 exitWith ec
27 let dryRun = sort $ filter notOptionalCore $ map (takeWhile (/= ' ')) $ drop 2 $ lines dryRun'
27 let dryRun = sort $ filter notOptionalCore $ map (takeWhile (/= ' ')) $ drop 2 $ lines dryRun'
28− let mismatches = getMismatches dryRun (filter notOptionalCore $ iiPackageList ii)
28+ let mismatches = getMismatches dryRun (filter notOptionalCore $ bpPackageList bp)
29 unless (null mismatches) $ do
29 unless (null mismatches) $ do
30 putStrLn "Found the following mismatches"
30 putStrLn "Found the following mismatches"
31 mapM_ print mismatches
31 mapM_ print mismatches
32 exitWith $ ExitFailure 1
32 exitWith $ ExitFailure 1
33 where
33 where
34− optionalCore = Set.fromList $ map packageVersionString $ Map.toList $ iiOptionalCore ii
34+ optionalCore = Set.fromList $ map packageVersionString $ Map.toList $ bpOptionalCore bp
35 notOptionalCore s = not $ s `Set.member` optionalCore
35 notOptionalCore s = not $ s `Set.member` optionalCore
36
36
37getMismatches :: [String] -> [String] -> [Mismatch]
37getMismatches :: [String] -> [String] -> [Mismatch]
Stackage/InstallInfo.hs+20−8
@@ -1,6 +1,7 @@
1+{-# LANGUAGE RecordWildCards #-}
1module Stackage.InstallInfo
2module Stackage.InstallInfo
2 ( getInstallInfo
3 ( getInstallInfo
3− , iiPackageList
4+ , bpPackageList
4 ) where
5 ) where
5
6
6import Control.Arrow ((&&&))
7import Control.Arrow ((&&&))
@@ -60,28 +61,39 @@ getInstallInfo settings = do
60
61
61 return InstallInfo
62 return InstallInfo
62 { iiCore = totalCore
63 { iiCore = totalCore
63− , iiPackages = Map.map (biVersion &&& biMaintainer) final
64+ , iiPackages = Map.map biToSPI final
64 , iiOptionalCore = Map.fromList $ map (\(PackageIdentifier p v) -> (p, v)) $ Set.toList $ hplibs hp
65 , iiOptionalCore = Map.fromList $ map (\(PackageIdentifier p v) -> (p, v)) $ Set.toList $ hplibs hp
65 , iiPackageDB = pdb
66 , iiPackageDB = pdb
66 }
67 }
67
68
69+biToSPI :: BuildInfo -> SelectedPackageInfo
70+biToSPI BuildInfo {..} = SelectedPackageInfo
71+ { spiVersion = biVersion
72+ , spiMaintainer = biMaintainer
73+ , spiGithubUser = biGithubUser
74+ , spiHasTests = biHasTests
75+ }
76+
68showDep :: (PackageName, BuildInfo) -> String
77showDep :: (PackageName, BuildInfo) -> String
69−showDep (PackageName name, (BuildInfo version deps (Maintainer m) _)) =
78+showDep (PackageName name, BuildInfo {..}) =
70 concat
79 concat
71 [ name
80 [ name
72 , "-"
81 , "-"
73− , showVersion version
82+ , showVersion biVersion
74 , " ("
83 , " ("
75− , m
84+ , unMaintainer biMaintainer
85+ , case biGithubUser of
86+ Nothing -> ""
87+ Just x -> " @" ++ x
76 , ")"
88 , ")"
77 , ": "
89 , ": "
78− , unwords $ map unP deps
90+ , unwords $ map unP biUsers
79 ]
91 ]
80 where
92 where
81 unP (PackageName p) = p
93 unP (PackageName p) = p
82
94
83−iiPackageList :: InstallInfo -> [String]
95+bpPackageList :: BuildPlan -> [String]
84−iiPackageList = map packageVersionString . Map.toList . Map.map fst . iiPackages
96+bpPackageList = map packageVersionString . Map.toList . Map.map spiVersion . bpPackages
85
97
86-- | Check for internal mismatches in required and actual package versions.
98-- | Check for internal mismatches in required and actual package versions.
87checkBadVersions :: BuildSettings
99checkBadVersions :: BuildSettings
Stackage/NarrowDatabase.hs+2
@@ -38,6 +38,8 @@ narrowPackageDB settings (PackageDB pdb) packageSet = do
38 , biUsers = users
38 , biUsers = users
39 , biMaintainer = maintainer
39 , biMaintainer = maintainer
40 , biDeps = piDeps pi
40 , biDeps = piDeps pi
41+ , biGithubUser = piGithubUser pi
42+ , biHasTests = piHasTests pi
41 } result
43 } result
42 case piGPD pi of
44 case piGPD pi of
43 Nothing -> return ()
45 Nothing -> return ()
Stackage/Select.hsnew file+74
@@ -0,0 +1,74 @@
1+module Stackage.Select
2+ ( select
3+ ) where
4+
5+import Control.Exception (assert)
6+import Control.Monad (unless, when)
7+import qualified Data.Map as Map
8+import Data.Maybe (mapMaybe)
9+import Data.Set (empty)
10+import qualified Data.Set as Set
11+import Distribution.Text (simpleParse)
12+import Distribution.Version (withinRange)
13+import Prelude hiding (pi)
14+import Stackage.CheckPlan
15+import Stackage.Config
16+import Stackage.InstallInfo
17+import Stackage.Tarballs
18+import Stackage.Test
19+import Stackage.Types
20+import Stackage.Util
21+import System.Directory (canonicalizePath,
22+ createDirectoryIfMissing,
23+ doesDirectoryExist)
24+import System.Exit (ExitCode (ExitSuccess), exitWith)
25+import System.IO (IOMode (WriteMode), hPutStrLn,
26+ withBinaryFile)
27+import System.Process (rawSystem, readProcess, runProcess,
28+ waitForProcess)
29+import Stackage.BuildPlan
30+
31+select :: BuildSettings -> IO BuildPlan
32+select settings' = do
33+ ii <- getInstallInfo settings'
34+
35+ let bp = BuildPlan
36+ { bpTools = iiBuildTools ii
37+ , bpPackages = iiPackages ii
38+ , bpOptionalCore = iiOptionalCore ii
39+ , bpCore = iiCore ii
40+ }
41+
42+ writeBuildPlan "build-plan.txt" bp -- FIXME
43+ readBuildPlan "build-plan.txt"
44+ --return bp
45+
46+-- | Get all of the build tools required.
47+iiBuildTools :: InstallInfo -> [String]
48+iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
49+ -- FIXME possible improvement: track the dependencies between the build
50+ -- tools themselves, and install them in the correct order.
51+ map packageVersionString
52+ $ filter (flip Set.notMember coreTools . fst)
53+ $ mapMaybe (flip Map.lookup buildToolMap)
54+ $ Set.toList
55+ $ Set.unions
56+ $ map piBuildTools
57+ $ Map.elems
58+ $ Map.filterWithKey isSelected m
59+ where
60+ unPackageName (PackageName pn) = pn
61+ isSelected name _ = name `Set.member` selected
62+ selected = Set.fromList $ Map.keys packages
63+
64+ -- Build tools shipped with GHC which we should not attempt to build
65+ -- ourselves.
66+ coreTools = Set.fromList $ map PackageName $ words "hsc2hs"
67+
68+ -- The map from build tool name to the package it comes from.
69+ buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m
70+ toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
71+ toBuildToolMap (pn, pi) = Map.unions
72+ $ map (flip Map.singleton (pn, piVersion pi))
73+ $ Set.toList
74+ $ piExecs pi
Stackage/Tarballs.hs+6−6
@@ -11,8 +11,8 @@ import Stackage.Util
11import System.Directory (createDirectoryIfMissing)
11import System.Directory (createDirectoryIfMissing)
12import System.FilePath (takeDirectory)
12import System.FilePath (takeDirectory)
13
13
14−makeTarballs :: InstallInfo -> IO ()
14+makeTarballs :: BuildPlan -> IO ()
15−makeTarballs ii = do
15+makeTarballs bp = do
16 tarName <- getTarballName
16 tarName <- getTarballName
17 origEntries <- fmap Tar.read $ L.readFile tarName
17 origEntries <- fmap Tar.read $ L.readFile tarName
18 (stableEntries, extraEntries) <- loop id id origEntries
18 (stableEntries, extraEntries) <- loop id id origEntries
@@ -35,10 +35,10 @@ makeTarballs ii = do
35 case getPackageVersion e of
35 case getPackageVersion e of
36 Nothing -> (stable, extra)
36 Nothing -> (stable, extra)
37 Just (package, version) ->
37 Just (package, version) ->
38− case Map.lookup package $ iiPackages ii of
38+ case Map.lookup package $ bpPackages bp of
39− Just (version', _maintainer)
39+ Just spi
40− | version == version' -> (stable . (e:), extra)
40+ | version == spiVersion spi -> (stable . (e:), extra)
41 | otherwise -> (stable, extra)
41 | otherwise -> (stable, extra)
42 Nothing
42 Nothing
43− | package `Set.member` iiCore ii -> (stable, extra)
43+ | package `Set.member` bpCore bp -> (stable, extra)
44 | otherwise -> (stable, extra . (e:))
44 | otherwise -> (stable, extra . (e:))
Stackage/Test.hs+18−13
@@ -1,4 +1,5 @@
1{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE RecordWildCards #-}
2module Stackage.Test
3module Stackage.Test
3 ( runTestSuites
4 ( runTestSuites
4 ) where
5 ) where
@@ -18,17 +19,13 @@ import System.IO (IOMode (WriteMode, AppendMode),
18 withBinaryFile)
19 withBinaryFile)
19import System.Process (runProcess, waitForProcess)
20import System.Process (runProcess, waitForProcess)
20
21
21−runTestSuites :: BuildSettings -> InstallInfo -> IO ()
22+runTestSuites :: BuildSettings -> Map PackageName SelectedPackageInfo -> IO ()
22−runTestSuites settings ii = do
23+runTestSuites settings selected = do
23 let testdir = "runtests"
24 let testdir = "runtests"
24 rm_r testdir
25 rm_r testdir
25 createDirectory testdir
26 createDirectory testdir
26− allPass <- parFoldM (testWorkerThreads settings) (runTestSuite settings testdir hasTestSuites) (&&) True $ Map.toList $ iiPackages ii
27+ allPass <- parFoldM (testWorkerThreads settings) (runTestSuite settings testdir) (&&) True $ Map.toList selected
27 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
28 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
28− where
29− PackageDB pdb = iiPackageDB ii
30−
31− hasTestSuites name = maybe defaultHasTestSuites piHasTests $ Map.lookup name pdb
32
29
33parFoldM :: Int -- ^ number of threads
30parFoldM :: Int -- ^ number of threads
34 -> (b -> IO c)
31 -> (b -> IO c)
@@ -76,10 +73,9 @@ instance Exception TestException
76
73
77runTestSuite :: BuildSettings
74runTestSuite :: BuildSettings
78 -> FilePath
75 -> FilePath
79− -> (PackageName -> Bool) -- ^ do we have any test suites?
76+ -> (PackageName, SelectedPackageInfo)
80− -> (PackageName, (Version, Maintainer))
81 -> IO Bool
77 -> IO Bool
82−runTestSuite settings testdir hasTestSuites (packageName, (version, Maintainer maintainer)) = do
78+runTestSuite settings testdir (packageName, SelectedPackageInfo {..}) = do
83 -- Set up a new environment that includes the sandboxed bin folder in PATH.
79 -- Set up a new environment that includes the sandboxed bin folder in PATH.
84 env' <- getModifiedEnv settings
80 env' <- getModifiedEnv settings
85 let menv addGPP
81 let menv addGPP
@@ -98,7 +94,7 @@ runTestSuite settings testdir hasTestSuites (packageName, (version, Maintainer m
98 passed <- handle (\TestException -> return False) $ do
94 passed <- handle (\TestException -> return False) $ do
99 getHandle WriteMode $ run "cabal" ["unpack", package] testdir
95 getHandle WriteMode $ run "cabal" ["unpack", package] testdir
100 getHandle AppendMode $ run "cabal" (addCabalArgs settings ["configure", "--enable-tests"]) dir
96 getHandle AppendMode $ run "cabal" (addCabalArgs settings ["configure", "--enable-tests"]) dir
101− when (hasTestSuites packageName) $ do
97+ when spiHasTests $ do
102 getHandle AppendMode $ run "cabal" ["build"] dir
98 getHandle AppendMode $ run "cabal" ["build"] dir
103 getHandle AppendMode $ runGhcPackagePath "cabal" ["test"] dir
99 getHandle AppendMode $ runGhcPackagePath "cabal" ["test"] dir
104 getHandle AppendMode $ run "cabal" ["haddock"] dir
100 getHandle AppendMode $ run "cabal" ["haddock"] dir
@@ -108,11 +104,20 @@ runTestSuite settings testdir hasTestSuites (packageName, (version, Maintainer m
108 then do
104 then do
109 removeFile logfile
105 removeFile logfile
110 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
106 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
111− else unless expectedFailure $ putStrLn $ "Test suite failed: " ++ package ++ "(" ++ maintainer ++ ")"
107+ else unless expectedFailure $ putStrLn $ concat
108+ [ "Test suite failed: "
109+ , package
110+ , "("
111+ , unMaintainer spiMaintainer
112+ , case spiGithubUser of
113+ Nothing -> ""
114+ Just x -> " @" ++ x
115+ , ")"
116+ ]
112 rm_r dir
117 rm_r dir
113 return $! passed || expectedFailure
118 return $! passed || expectedFailure
114 where
119 where
115 logfile = testdir </> package <.> "log"
120 logfile = testdir </> package <.> "log"
116 dir = testdir </> package
121 dir = testdir </> package
117 getHandle mode = withBinaryFile logfile mode
122 getHandle mode = withBinaryFile logfile mode
118− package = packageVersionString (packageName, version)
123+ package = packageVersionString (packageName, spiVersion)
Stackage/Types.hs+20−3
@@ -46,6 +46,8 @@ data BuildInfo = BuildInfo
46 , biUsers :: [PackageName]
46 , biUsers :: [PackageName]
47 , biMaintainer :: Maintainer
47 , biMaintainer :: Maintainer
48 , biDeps :: Map PackageName VersionRange
48 , biDeps :: Map PackageName VersionRange
49+ , biGithubUser :: Maybe String
50+ , biHasTests :: Bool
49 }
51 }
50
52
51data HaskellPlatform = HaskellPlatform
53data HaskellPlatform = HaskellPlatform
@@ -59,7 +61,7 @@ instance Monoid HaskellPlatform where
59
61
60data InstallInfo = InstallInfo
62data InstallInfo = InstallInfo
61 { iiCore :: Set PackageName
63 { iiCore :: Set PackageName
62− , iiPackages :: Map PackageName (Version, Maintainer)
64+ , iiPackages :: Map PackageName SelectedPackageInfo
63 , iiOptionalCore :: Map PackageName Version
65 , iiOptionalCore :: Map PackageName Version
64 -- ^ This is intended to hold onto packages which might be automatically
66 -- ^ This is intended to hold onto packages which might be automatically
65 -- provided in the global package database. In practice, this would be
67 -- provided in the global package database. In practice, this would be
@@ -67,9 +69,25 @@ data InstallInfo = InstallInfo
67 , iiPackageDB :: PackageDB
69 , iiPackageDB :: PackageDB
68 }
70 }
69
71
72+data SelectedPackageInfo = SelectedPackageInfo
73+ { spiVersion :: Version
74+ , spiMaintainer :: Maintainer
75+ , spiGithubUser :: Maybe String
76+ , spiHasTests :: Bool
77+ }
78+ deriving (Show, Read)
79+
80+data BuildPlan = BuildPlan
81+ { bpTools :: [String]
82+ , bpPackages :: Map PackageName SelectedPackageInfo
83+ , bpCore :: Set PackageName
84+ , bpOptionalCore :: Map PackageName Version
85+ -- ^ See 'iiOptionalCore'
86+ }
87+
70-- | Email address of a Stackage maintainer.
88-- | Email address of a Stackage maintainer.
71newtype Maintainer = Maintainer { unMaintainer :: String }
89newtype Maintainer = Maintainer { unMaintainer :: String }
72− deriving (Show, Eq, Ord)
90+ deriving (Show, Eq, Ord, Read)
73
91
74data BuildSettings = BuildSettings
92data BuildSettings = BuildSettings
75 { sandboxRoot :: FilePath
93 { sandboxRoot :: FilePath
@@ -80,7 +98,6 @@ data BuildSettings = BuildSettings
80 , extraArgs :: [String]
98 , extraArgs :: [String]
81 , haskellPlatformCabal :: FilePath
99 , haskellPlatformCabal :: FilePath
82 , requireHaskellPlatform :: Bool
100 , requireHaskellPlatform :: Bool
83− , cleanBeforeBuild :: Bool
84 , excludedPackages :: Set PackageName
101 , excludedPackages :: Set PackageName
85 -- ^ Packages which should be dropped from the list of stable packages,
102 -- ^ Packages which should be dropped from the list of stable packages,
86 -- even if present via the Haskell Platform or @stablePackages@. If these
103 -- even if present via the Haskell Platform or @stablePackages@. If these
Stackage/Util.hs+21−3
@@ -19,6 +19,9 @@ import System.FilePath ((</>))
19import qualified Distribution.Package as P
19import qualified Distribution.Package as P
20import qualified Distribution.PackageDescription as PD
20import qualified Distribution.PackageDescription as PD
21import Distribution.License (License (..))
21import Distribution.License (License (..))
22+import System.Directory (canonicalizePath,
23+ createDirectoryIfMissing,
24+ doesDirectoryExist)
22
25
23-- | Allow only packages with permissive licenses.
26-- | Allow only packages with permissive licenses.
24allowPermissive :: [String] -- ^ list of explicitly allowed packages
27allowPermissive :: [String] -- ^ list of explicitly allowed packages
@@ -94,11 +97,16 @@ binDir = (</> "bin") . sandboxRoot
94dataDir = (</> "share") . sandboxRoot
97dataDir = (</> "share") . sandboxRoot
95docDir x = sandboxRoot x </> "share" </> "doc" </> "$pkgid"
98docDir x = sandboxRoot x </> "share" </> "doc" </> "$pkgid"
96
99
97−addCabalArgs :: BuildSettings -> [String] -> [String]
100+addCabalArgsOnlyGlobal :: [String] -> [String]
98−addCabalArgs settings rest
101+addCabalArgsOnlyGlobal rest
99 = "--package-db=clear"
102 = "--package-db=clear"
100 : "--package-db=global"
103 : "--package-db=global"
104+ : rest
105+
106+addCabalArgs :: BuildSettings -> [String] -> [String]
107+addCabalArgs settings rest
108+ = addCabalArgsOnlyGlobal
101− : ("--package-db=" ++ packageDir settings)
109+ $ ("--package-db=" ++ packageDir settings)
102 : ("--libdir=" ++ libDir settings)
110 : ("--libdir=" ++ libDir settings)
103 : ("--bindir=" ++ binDir settings)
111 : ("--bindir=" ++ binDir settings)
104 : ("--datadir=" ++ dataDir settings)
112 : ("--datadir=" ++ dataDir settings)
@@ -121,3 +129,13 @@ getModifiedEnv settings = do
121#else
129#else
122 pathSep = ':'
130 pathSep = ':'
123#endif
131#endif
132+
133+-- | Minor fixes, such as making paths absolute.
134+--
135+-- Note: creates the sandbox root in the process.
136+fixBuildSettings :: BuildSettings -> IO BuildSettings
137+fixBuildSettings settings' = do
138+ let root' = sandboxRoot settings'
139+ createDirectoryIfMissing True root'
140+ root <- canonicalizePath root'
141+ return settings' { sandboxRoot = root }
app/stackage.hs+3−7
@@ -8,8 +8,7 @@ import Data.Set (fromList)
8import System.IO (hFlush, stdout)
8import System.IO (hFlush, stdout)
9
9
10data BuildArgs = BuildArgs
10data BuildArgs = BuildArgs
11− { noClean :: Bool
12− , excluded :: [String]
11+ { excluded :: [String]
13 , noPlatform :: Bool
12 , noPlatform :: Bool
14 , onlyPermissive :: Bool
13 , onlyPermissive :: Bool
15 , allowed :: [String]
14 , allowed :: [String]
@@ -18,15 +17,13 @@ data BuildArgs = BuildArgs
18parseBuildArgs :: [String] -> IO BuildArgs
17parseBuildArgs :: [String] -> IO BuildArgs
19parseBuildArgs =
18parseBuildArgs =
20 loop BuildArgs
19 loop BuildArgs
21− { noClean = False
22− , excluded = []
20+ { excluded = []
23 , noPlatform = False
21 , noPlatform = False
24 , onlyPermissive = False
22 , onlyPermissive = False
25 , allowed = []
23 , allowed = []
26 }
24 }
27 where
25 where
28 loop x [] = return x
26 loop x [] = return x
29− loop x ("--no-clean":rest) = loop x { noClean = True } rest
30 loop x ("--exclude":y:rest) = loop x { excluded = y : excluded x } rest
27 loop x ("--exclude":y:rest) = loop x { excluded = y : excluded x } rest
31 loop x ("--no-platform":rest) = loop x { noPlatform = True } rest
28 loop x ("--no-platform":rest) = loop x { noPlatform = True } rest
32 loop x ("--only-permissive":rest) = loop x { onlyPermissive = True } rest
29 loop x ("--only-permissive":rest) = loop x { onlyPermissive = True } rest
@@ -40,8 +37,7 @@ main = do
40 "build":rest -> do
37 "build":rest -> do
41 BuildArgs {..} <- parseBuildArgs rest
38 BuildArgs {..} <- parseBuildArgs rest
42 build defaultBuildSettings
39 build defaultBuildSettings
43− { cleanBeforeBuild = not noClean
44− , excludedPackages = fromList $ map PackageName excluded
40+ { excludedPackages = fromList $ map PackageName excluded
45 , requireHaskellPlatform = not noPlatform
41 , requireHaskellPlatform = not noPlatform
46 , allowedPackage =
42 , allowedPackage =
47 if onlyPermissive
43 if onlyPermissive
stackage.cabal+3
@@ -24,6 +24,9 @@ library
24 Stackage.Test
24 Stackage.Test
25 Stackage.Build
25 Stackage.Build
26 Stackage.Init
26 Stackage.Init
27+ Stackage.BuildPlan
28+ Stackage.CheckCabalVersion
29+ Stackage.Select
27 build-depends: base >= 4 && < 5
30 build-depends: base >= 4 && < 5
28 , containers
31 , containers
29 , Cabal
32 , Cabal