BuildSettings

Stackage/Build.hs

@@ -1,14 +1,18 @@
 module Stackage.Build
     ( build
+    , defaultBuildSettings
+    , BuildSettings (..)
     ) where
 
 import           Distribution.Text       (simpleParse)
 import           Control.Monad        (unless)
+import           Stackage.Types
 import           Stackage.CheckPlan
 import           Stackage.InstallInfo
 import           Stackage.Tarballs
 import           Stackage.Test
 import           Stackage.Util
+import           Stackage.Config
 import           System.Exit          (ExitCode (ExitSuccess), exitWith)
 import           System.IO            (IOMode (WriteMode), withBinaryFile)
 import           System.Process       (runProcess, waitForProcess, rawSystem, readProcess)
@@ -16,27 +20,35 @@ import           System.Directory     (createDirectoryIfMissing, canonicalizePat
 import           Distribution.Version    (thisVersion, withinRange)
 import Control.Exception (assert)
 
-build :: FilePath
+defaultBuildSettings :: BuildSettings
-      -> ([String] -> [String]) -- ^ extra build rgs
+defaultBuildSettings = BuildSettings
-      -> IO ()
+    { sandboxRoot = "sandbox"
-build root' extraBuildArgs = do
+    , extraBuildArgs = []
+    , extraCore = defaultExtraCore
+    , expectedFailures = defaultExpectedFailures
+    , stablePackages = defaultStablePackages
+    , extraArgs = ["-fnetwork23"]
+    }
+
+build :: BuildSettings -> IO ()
+build settings' = do
     putStrLn "Creating a build plan"
-    ii <- getInstallInfo
+    ii <- getInstallInfo settings'
 
     putStrLn "Wiping out old sandbox folder"
+    let root' = sandboxRoot settings'
     rm_r root'
     rm_r "logs"
     createDirectoryIfMissing True root'
     root <- canonicalizePath root'
+    let settings = settings' { sandboxRoot = root }
 
-    ec1 <- rawSystem "ghc-pkg" ["init", packageDir root]
+    ec1 <- rawSystem "ghc-pkg" ["init", packageDir settings]
     unless (ec1 == ExitSuccess) $ do
         putStrLn "Unable to create package database via ghc-pkg init"
         exitWith ec1
 
-    let extraArgs = ("-fnetwork23":)
+    checkPlan settings ii
-
-    checkPlan (addCabalArgs root . extraArgs) ii
     putStrLn "No mismatches, starting the sandboxed build."
 
     versionString <- readProcess "cabal" ["--version"] ""
@@ -53,13 +65,16 @@ build root' extraBuildArgs = do
             | otherwise -> error $ "Unsupported Cabal version: " ++ libVersion
 
     ph <- withBinaryFile "build.log" WriteMode $ \handle ->
-        let args = addCabalArgs root
+        let args = addCabalArgs settings
                  $ "install"
                  : ("--cabal-lib-version=" ++ libVersion)
                  : "--build-log=logs/$pkg.log"
-                 : "--enable-shared"
                  : "-j"
-                 : (extraBuildArgs . extraArgs) (iiPackageList ii)
+                 : concat
+                    [ extraBuildArgs settings
+                    , extraArgs settings
+                    , iiPackageList ii
+                    ]
          in runProcess "cabal" args Nothing Nothing Nothing (Just handle) (Just handle)
     ec <- waitForProcess ph
     unless (ec == ExitSuccess) $ do
@@ -67,7 +82,7 @@ build root' extraBuildArgs = do
         exitWith ec
 
     putStrLn "Sandbox built, beginning individual test suites"
-    runTestSuites root ii
+    runTestSuites settings ii
 
     putStrLn "All test suites that were expected to pass did pass, building tarballs."
     makeTarballs ii

Stackage/CheckPlan.hs

@@ -16,9 +16,9 @@ import           System.Process       (readProcessWithExitCode)
 data Mismatch = OnlyDryRun String | OnlySimpleList String
     deriving Show
 
-checkPlan :: ([String] -> [String]) -> InstallInfo -> IO ()
+checkPlan :: BuildSettings -> InstallInfo -> IO ()
-checkPlan extraArgs ii = do
+checkPlan settings ii = do
-    (ec, dryRun', stderr) <- readProcessWithExitCode "cabal" (extraArgs $ "install":"--dry-run":iiPackageList ii) ""
+    (ec, dryRun', stderr) <- readProcessWithExitCode "cabal" (addCabalArgs settings $ "install":"--dry-run":iiPackageList ii) ""
     when (ec /= ExitSuccess || "Warning:" `isPrefixOf` stderr) $ do
         putStr stderr
         putStr dryRun'

Stackage/Config.hs

@@ -15,14 +15,14 @@ targetCompilerVersion =
 
 -- | Packages which are shipped with GHC but are not included in the
 -- Haskell Platform list of core packages.
-extraCore :: Set PackageName
+defaultExtraCore :: Set PackageName
-extraCore = singleton $ PackageName "binary"
+defaultExtraCore = singleton $ PackageName "binary"
 
 -- | Test suites which are expected to fail for some reason. The test suite
 -- will still be run and logs kept, but a failure will not indicate an
 -- error in our package combination.
-expectedFailures :: Set PackageName
+defaultExpectedFailures :: Set PackageName
-expectedFailures = fromList $ map PackageName
+defaultExpectedFailures = fromList $ map PackageName
     [ -- Requires an old version of WAI and Warp for tests
       "HTTP"
       -- Requires a special hspec-meta which is not yet available from
@@ -58,8 +58,8 @@ expectedFailures = fromList $ map PackageName
 -- | List of packages for our stable Hackage. All dependencies will be
 -- included as well. Please indicate who will be maintaining the package
 -- via comments.
-stablePackages :: Map PackageName (VersionRange, Maintainer)
+defaultStablePackages :: Map PackageName (VersionRange, Maintainer)
-stablePackages = execWriter $ do
+defaultStablePackages = execWriter $ do
     mapM_ (add "michael@snoyman.com") $ words
         "yesod yesod-newsfeed yesod-sitemap yesod-static yesod-test markdown filesystem-conduit mime-mail-ses"
 
@@ -80,11 +80,3 @@ stablePackages = execWriter $ do
         case simpleParse range of
             Nothing -> error $ "Invalid range " ++ show range ++ " for " ++ package
             Just range' -> tell $ Map.singleton (PackageName package) (range', Maintainer maintainer)
-
-verbose :: Bool
-verbose =
-#if VERBOSE
-    True
-#else
-    False
-#endif

Stackage/InstallInfo.hs

@@ -13,11 +13,11 @@ import           Stackage.Types
 import           Stackage.Util
 import Data.Version (showVersion)
 
-getInstallInfo :: IO InstallInfo
+getInstallInfo :: BuildSettings -> IO InstallInfo
-getInstallInfo = do
+getInstallInfo settings = do
     hp <- loadHaskellPlatform
-    let allPackages = Map.union stablePackages $ identsToRanges (hplibs hp)
+    let allPackages = Map.union (stablePackages settings) $ identsToRanges (hplibs hp)
-    let totalCore = extraCore `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp)
+    let totalCore = extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp)
     pdb <- loadPackageDB totalCore allPackages
     final <- narrowPackageDB pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages
 

Stackage/Test.hs

@@ -20,12 +20,12 @@ import           System.Process     (runProcess, waitForProcess)
 import Control.Exception (handle, Exception, throwIO)
 import Data.Typeable (Typeable)
 
-runTestSuites :: FilePath -> InstallInfo -> IO ()
+runTestSuites :: BuildSettings -> InstallInfo -> IO ()
-runTestSuites root ii = do
+runTestSuites settings ii = do
     let testdir = "runtests"
     rm_r testdir
     createDirectory testdir
-    allPass <- foldM (runTestSuite root testdir hasTestSuites) True $ Map.toList $ iiPackages ii
+    allPass <- foldM (runTestSuite settings testdir hasTestSuites) True $ Map.toList $ iiPackages ii
     unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
   where
     PackageDB pdb = iiPackageDB ii
@@ -48,16 +48,16 @@ data TestException = TestException
     deriving (Show, Typeable)
 instance Exception TestException
 
-runTestSuite :: FilePath
+runTestSuite :: BuildSettings
              -> FilePath
              -> (PackageName -> Bool) -- ^ do we have any test suites?
              -> Bool
              -> (PackageName, (Version, Maintainer))
              -> IO Bool
-runTestSuite root testdir hasTestSuites prevPassed (packageName, (version, Maintainer maintainer)) = do
+runTestSuite settings testdir hasTestSuites prevPassed (packageName, (version, Maintainer maintainer)) = do
     -- Set up a new environment that includes the sandboxed bin folder in PATH.
     env' <- getEnvironment
-    let menv = Just $ map (fixEnv $ binDir root) env'
+    let menv = Just $ map (fixEnv $ binDir settings) env'
 
     let run cmd args wdir handle = do
             ph <- runProcess cmd args (Just wdir) menv Nothing (Just handle) (Just handle)
@@ -66,13 +66,13 @@ runTestSuite root testdir hasTestSuites prevPassed (packageName, (version, Maint
 
     passed <- handle (\TestException -> return False) $ do
         getHandle WriteMode  $ run "cabal" ["unpack", package] testdir
-        getHandle AppendMode $ run "cabal" (addCabalArgs root ["configure", "--enable-tests"]) dir
+        getHandle AppendMode $ run "cabal" (addCabalArgs settings ["configure", "--enable-tests"]) dir
         when (hasTestSuites packageName) $ do
             getHandle AppendMode $ run "cabal" ["build"] dir
             getHandle AppendMode $ run "cabal" ["test"] dir
         getHandle AppendMode $ run "cabal" ["haddock"] dir
         return True
-    let expectedFailure = packageName `Set.member` expectedFailures
+    let expectedFailure = packageName `Set.member` expectedFailures settings
     if passed
         then do
             removeFile logfile

Stackage/Types.hs

@@ -53,3 +53,12 @@ data InstallInfo = InstallInfo
 -- | Email address of a Stackage maintainer.
 newtype Maintainer = Maintainer { unMaintainer :: String }
     deriving (Show, Eq, Ord)
+
+data BuildSettings = BuildSettings
+    { sandboxRoot :: FilePath
+    , extraBuildArgs :: [String]
+    , extraCore :: Set PackageName
+    , expectedFailures :: Set PackageName
+    , stablePackages :: Map PackageName (VersionRange, Maintainer)
+    , extraArgs :: [String]
+    }

Stackage/Util.hs

@@ -69,14 +69,14 @@ getPackageVersion e = do
 defaultHasTestSuites :: Bool
 defaultHasTestSuites = True
 
-packageDir = (</> "package-db")
+packageDir = (</> "package-db") . sandboxRoot
-libDir = (</> "lib")
+libDir = (</> "lib") . sandboxRoot
-binDir = (</> "bin")
+binDir = (</> "bin") . sandboxRoot
 
-addCabalArgs root rest
+addCabalArgs settings rest
     = "--package-db=clear"
     : "--package-db=global"
-    : ("--package-db=" ++ packageDir root)
+    : ("--package-db=" ++ packageDir settings)
-    : ("--libdir=" ++ libDir root)
+    : ("--libdir=" ++ libDir settings)
-    : ("--bindir=" ++ binDir root)
+    : ("--bindir=" ++ binDir settings)
-    : rest
+    : extraArgs settings ++ rest

app/stackage.hs

@@ -1,4 +1,4 @@
-import           Stackage.Build     (build)
+import           Stackage.Build     (build, defaultBuildSettings)
 import           Stackage.Init      (stackageInit)
 import           System.Environment (getArgs, getProgName)
 
@@ -6,7 +6,7 @@ main :: IO ()
 main = do
     args <- getArgs
     case args of
-        ["build"] -> build "sandbox" id
+        ["build"] -> build defaultBuildSettings
         ["init"] -> stackageInit
         ["update"] -> stackageInit >> error "FIXME update"
         _ -> do