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