Commit 97cff5c0 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Convert new-build to use InstallPlan.execute

Eliminate the local executeInstallPlan. The main change is that the new
execute returns BuildResults instead of an upated InstallPlan. This has
a few knock-on conseuqnces for the code that looks at the result of the
build execution.

Currently we don't actually do that much with the results in the
new-build code path (though we should) so there's less disruption than
one might imagine. The biggest change is in the integration tests which
do inspect the execution result to check things worked or didn't work as
expected.

The equivalent change for the old build code path will be more
disruptive since it does a lot of stuff with the execution results.
parent 31be24fa
......@@ -346,20 +346,22 @@ improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan
-> BuildStatusMap
-> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus =
replaceWithPreInstalled installPlan
[ (installedPackageId pkg, ipkgs, buildSuccess)
replaceWithPrePreExisting installPlan
[ (installedPackageId pkg, ipkgs)
| InstallPlan.Configured pkg
<- InstallPlan.reverseTopologicalOrder installPlan
, let ipkgid = installedPackageId pkg
Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus
, BuildStatusUpToDate ipkgs buildSuccess <- [pkgBuildStatus]
, BuildStatusUpToDate ipkgs _buildSuccess <- [pkgBuildStatus]
]
where
replaceWithPreInstalled =
foldl' (\plan (ipkgid, ipkgs, buildSuccess) ->
InstallPlan.preinstalled ipkgid
(find (\ipkg -> installedPackageId ipkg == ipkgid) ipkgs)
buildSuccess plan)
replaceWithPrePreExisting =
foldl' (\plan (ipkgid, ipkgs) ->
case find (\ipkg -> installedPackageId ipkg == ipkgid) ipkgs of
Just ipkg -> InstallPlan.preexisting ipkgid ipkg plan
Nothing -> unexpected)
unexpected =
error "improveInstallPlanWithUpToDatePackages: dep on non lib package"
-----------------------------
......@@ -571,7 +573,7 @@ rebuildTargets :: Verbosity
-> ElaboratedSharedConfig
-> BuildStatusMap
-> BuildTimeSettings
-> IO ElaboratedInstallPlan
-> IO BuildResults
rebuildTargets verbosity
distDirLayout@DistDirLayout{..}
installPlan
......@@ -604,7 +606,10 @@ rebuildTargets verbosity
installPlan pkgsBuildStatus $ \downloadMap ->
-- For each package in the plan, in dependency order, but in parallel...
executeInstallPlan verbosity jobControl keepGoing installPlan $ \pkg ->
InstallPlan.execute jobControl keepGoing (DependentFailed . packageId)
installPlan $ \pkg ->
fmap (\x -> case x of BuildFailure f -> Left f
BuildSuccess _ s -> Right s) $
handle (return . BuildFailure) $ --TODO: review exception handling
let ipkgid = installedPackageId pkg
......@@ -792,94 +797,6 @@ waitAsyncPackageDownload verbosity downloadMap pkg =
fail "waitAsyncPackageDownload: package not being download"
executeInstallPlan
:: forall ipkg srcpkg iresult.
(HasUnitId ipkg, PackageFixedDeps ipkg,
HasUnitId srcpkg, PackageFixedDeps srcpkg)
=> Verbosity
-> JobControl IO ( GenericReadyPackage srcpkg
, GenericBuildResult ipkg iresult BuildFailure )
-> Bool
-> GenericInstallPlan ipkg srcpkg iresult BuildFailure
-> ( GenericReadyPackage srcpkg
-> IO (GenericBuildResult ipkg iresult BuildFailure))
-> IO (GenericInstallPlan ipkg srcpkg iresult BuildFailure)
executeInstallPlan verbosity jobCtl keepGoing plan0 installPkg =
tryNewTasks False False plan0
where
tryNewTasks :: Bool -> Bool
-> GenericInstallPlan ipkg srcpkg iresult BuildFailure
-> IO (GenericInstallPlan ipkg srcpkg iresult BuildFailure)
tryNewTasks tasksFailed tasksRemaining plan
| tasksFailed && not keepGoing && not tasksRemaining
= return plan
| tasksFailed && not keepGoing && tasksRemaining
= waitForTasks tasksFailed plan
tryNewTasks tasksFailed tasksRemaining plan = do
case InstallPlan.ready plan of
[] | not tasksRemaining -> return plan
| otherwise -> waitForTasks tasksFailed plan
pkgs -> do
sequence_
[ do debug verbosity $ "Ready to install " ++ display pkgid
spawnJob jobCtl $ do
buildResult <- installPkg pkg
return (pkg, buildResult)
| pkg <- pkgs
, let pkgid = packageId pkg
]
let plan' = InstallPlan.processing pkgs plan
waitForTasks tasksFailed plan'
waitForTasks :: Bool
-> GenericInstallPlan ipkg srcpkg iresult BuildFailure
-> IO (GenericInstallPlan ipkg srcpkg iresult BuildFailure)
waitForTasks tasksFailed plan = do
debug verbosity $ "Waiting for install task to finish..."
(pkg, buildResult) <- collectJob jobCtl
let plan' = updatePlan pkg buildResult plan
tasksFailed' = tasksFailed || isBuildFailure buildResult
-- if this is the first failure and we're not trying to keep going
-- then try to cancel as many of the remaining jobs as possible
when (not tasksFailed && isBuildFailure buildResult && not keepGoing) $
cancelJobs jobCtl
tasksRemaining <- remainingJobs jobCtl
tryNewTasks tasksFailed' tasksRemaining plan'
isBuildFailure (BuildFailure _) = True
isBuildFailure _ = False
updatePlan :: GenericReadyPackage srcpkg
-> GenericBuildResult ipkg iresult BuildFailure
-> GenericInstallPlan ipkg srcpkg iresult BuildFailure
-> GenericInstallPlan ipkg srcpkg iresult BuildFailure
updatePlan pkg (BuildSuccess ipkgs buildSuccess) =
InstallPlan.completed (installedPackageId pkg)
mipkg
buildSuccess
where
mipkg = case (ipkgs, find (\ipkg -> installedPackageId ipkg
== installedPackageId pkg) ipkgs) of
([], _) -> Nothing
((_:_), Just ipkg) -> Just ipkg
((_:_), Nothing) ->
error $ "executeInstallPlan: package " ++ display (packageId pkg)
++ " was expected to register the unit "
++ display (installedPackageId pkg)
++ " but is actually registering the unit(s) "
++ intercalate ", " (map (display . installedPackageId) ipkgs)
updatePlan pkg (BuildFailure buildFailure) =
InstallPlan.failed (installedPackageId pkg) buildFailure depsFailure
where
depsFailure = DependentFailed (packageId pkg)
-- So this first pkgid failed for whatever reason (buildFailure).
-- All the other packages that depended on this pkgid, which we
-- now cannot build, we mark as failing due to 'DependentFailed'
-- which kind of means it was not their fault.
-- | Ensure that the package is unpacked in an appropriate directory, either
......
......@@ -60,8 +60,8 @@ import Distribution.Client.ProjectPlanning
import Distribution.Client.ProjectBuilding
import Distribution.Client.Types
hiding ( BuildResult, BuildSuccess(..), BuildFailure(..)
, DocsResult(..), TestsResult(..) )
hiding ( BuildResult, BuildResults, BuildSuccess(..)
, BuildFailure(..), DocsResult(..), TestsResult(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.BuildTarget
( UserBuildTarget, resolveUserBuildTargets
......@@ -195,14 +195,22 @@ runProjectPreBuildPhase
--
runProjectBuildPhase :: Verbosity
-> ProjectBuildContext
-> IO ElaboratedInstallPlan
-> IO BuildResults
runProjectBuildPhase verbosity ProjectBuildContext {..} =
fmap (Map.union (previousBuildResults pkgsBuildStatus)) $
rebuildTargets verbosity
distDirLayout
elaboratedPlan
elaboratedShared
pkgsBuildStatus
buildSettings
where
previousBuildResults :: BuildStatusMap -> BuildResults
previousBuildResults =
Map.mapMaybe $ \status -> case status of
BuildStatusUpToDate _ buildSuccess -> Just (Right buildSuccess)
--TODO: [nice to have] record build failures persistently
_ -> Nothing
-- Note that it is a deliberate design choice that the 'buildTargets' is
-- not passed to phase 1, and the various bits of input config is not
......@@ -460,12 +468,11 @@ printPlan verbosity
showMonitorChangedReason MonitorCorruptCache = "cannot read state cache"
reportBuildFailures :: ElaboratedInstallPlan -> IO ()
reportBuildFailures :: BuildResults -> IO ()
reportBuildFailures plan =
case [ (pkg, reason)
| InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of
case [ (pkgid, reason)
| (pkgid, Left reason) <- Map.toList plan ] of
[] -> return ()
_failed -> exitFailure
--TODO: [required eventually] see the old printBuildFailures for an example
......
......@@ -16,6 +16,7 @@ module Distribution.Client.ProjectPlanning (
-- plan definition. Need to better separate InstallPlan definition.
GenericBuildResult(..),
BuildResult,
BuildResults,
BuildSuccess(..),
BuildFailure(..),
DocsResult(..),
......@@ -61,8 +62,8 @@ import Distribution.Client.ProjectConfig
import Distribution.Client.ProjectPlanOutput
import Distribution.Client.Types
hiding ( BuildResult, BuildSuccess(..), BuildFailure(..)
, DocsResult(..), TestsResult(..) )
hiding ( BuildResult, BuildResults, BuildSuccess(..)
, BuildFailure(..), DocsResult(..), TestsResult(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.Dependency
......
......@@ -21,6 +21,7 @@ module Distribution.Client.ProjectPlanning.Types (
-- plan definition. Need to better separate InstallPlan definition.
GenericBuildResult(..),
BuildResult,
BuildResults,
BuildSuccess(..),
BuildFailure(..),
DocsResult(..),
......@@ -38,8 +39,8 @@ module Distribution.Client.ProjectPlanning.Types (
import Distribution.Client.PackageHash
import Distribution.Client.Types
hiding ( BuildResult, BuildSuccess(..), BuildFailure(..)
, DocsResult(..), TestsResult(..) )
hiding ( BuildResult, BuildResults, BuildSuccess(..)
, BuildFailure(..), DocsResult(..), TestsResult(..) )
import Distribution.Client.InstallPlan
( GenericInstallPlan, GenericPlanPackage )
import Distribution.Client.SolverInstallPlan
......@@ -296,6 +297,7 @@ instance (Binary ipkg, Binary iresult, Binary ifailure) =>
type BuildResult = GenericBuildResult InstalledPackageInfo
BuildSuccess BuildFailure
type BuildResults = Map UnitId (Either BuildFailure BuildSuccess)
data BuildSuccess = BuildOk DocsResult TestsResult
deriving (Eq, Show, Generic)
......
......@@ -8,9 +8,8 @@ import Distribution.Client.ProjectPlanning
import Distribution.Client.ProjectPlanning.Types
import Distribution.Client.ProjectBuilding
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.Types (GenericReadyPackage(..), installedPackageId)
import Distribution.Package hiding (installedPackageId)
import Distribution.Package
import Distribution.PackageDescription
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import Distribution.Simple.Setup (toFlag)
......@@ -93,9 +92,8 @@ testExceptionInFindingPackage2 config = do
testExceptionInConfigureStep :: ProjectConfig -> Assertion
testExceptionInConfigureStep config = do
plan <- planProject testdir config
plan' <- executePlan plan
(_pkga1, failure) <- expectPackageFailed plan' pkgidA1
(plan, res) <- executePlan =<< planProject testdir config
(_pkga1, failure) <- expectPackageFailed plan res pkgidA1
case failure of
ConfigureFailed _str -> return ()
_ -> assertFailure $ "expected ConfigureFailed, got " ++ show failure
......@@ -107,9 +105,8 @@ testExceptionInConfigureStep config = do
testExceptionInBuildStep :: ProjectConfig -> Assertion
testExceptionInBuildStep config = do
plan <- planProject testdir config
plan' <- executePlan plan
(_pkga1, failure) <- expectPackageFailed plan' pkgidA1
(plan, res) <- executePlan =<< planProject testdir config
(_pkga1, failure) <- expectPackageFailed plan res pkgidA1
expectBuildFailed failure
where
testdir = "exception/build"
......@@ -119,8 +116,8 @@ testSetupScriptStyles :: ProjectConfig -> (String -> IO ()) -> Assertion
testSetupScriptStyles config reportSubCase = do
reportSubCase (show SetupCustomExplicitDeps)
plan1 <- executePlan =<< planProject testdir1 config
(pkg1, _, _) <- expectPackageInstalled plan1 pkgidA
(plan1, res1) <- executePlan =<< planProject testdir1 config
(pkg1, _) <- expectPackageInstalled plan1 res1 pkgidA
pkgSetupScriptStyle pkg1 @?= SetupCustomExplicitDeps
hasDefaultSetupDeps pkg1 @?= Just False
marker1 <- readFile (basedir </> testdir1 </> "marker")
......@@ -128,8 +125,8 @@ testSetupScriptStyles config reportSubCase = do
removeFile (basedir </> testdir1 </> "marker")
reportSubCase (show SetupCustomImplicitDeps)
plan2 <- executePlan =<< planProject testdir2 config
(pkg2, _, _) <- expectPackageInstalled plan2 pkgidA
(plan2, res2) <- executePlan =<< planProject testdir2 config
(pkg2, _) <- expectPackageInstalled plan2 res2 pkgidA
pkgSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps
hasDefaultSetupDeps pkg2 @?= Just True
marker2 <- readFile (basedir </> testdir2 </> "marker")
......@@ -137,8 +134,8 @@ testSetupScriptStyles config reportSubCase = do
removeFile (basedir </> testdir2 </> "marker")
reportSubCase (show SetupNonCustomInternalLib)
plan3 <- executePlan =<< planProject testdir3 config
(pkg3, _, _) <- expectPackageInstalled plan3 pkgidA
(plan3, res3) <- executePlan =<< planProject testdir3 config
(pkg3, _) <- expectPackageInstalled plan3 res3 pkgidA
pkgSetupScriptStyle pkg3 @?= SetupNonCustomInternalLib
{-
--TODO: the SetupNonCustomExternalLib case is hard to test since it
......@@ -147,8 +144,8 @@ testSetupScriptStyles config reportSubCase = do
-- and a corresponding Cabal package that we can use to try and build a
-- default Setup.hs.
reportSubCase (show SetupNonCustomExternalLib)
plan4 <- executePlan =<< planProject testdir4 config
(pkg4, _, _) <- expectPackageInstalled plan4 pkgidA
(plan4, res4) <- executePlan =<< planProject testdir4 config
(pkg4, _) <- expectPackageInstalled plan4 res4 pkgidA
pkgSetupScriptStyle pkg4 @?= SetupNonCustomExternalLib
-}
where
......@@ -166,16 +163,17 @@ testBuildKeepGoing :: ProjectConfig -> Assertion
testBuildKeepGoing config = do
-- P is expected to fail, Q does not depend on P but without
-- parallel build and without keep-going then we don't build Q yet.
plan1 <- executePlan =<< planProject testdir (config <> keepGoing False)
(_, failure1) <- expectPackageFailed plan1 pkgidP
(plan1, res1) <- executePlan =<< planProject testdir (config <> keepGoing False)
(_, failure1) <- expectPackageFailed plan1 res1 pkgidP
expectBuildFailed failure1
_ <- expectPackageProcessing plan1 pkgidQ
_ <- expectPackageConfigured plan1 res1 pkgidQ
-- With keep-going then we should go on to sucessfully build Q
plan2 <- executePlan =<< planProject testdir (config <> keepGoing True)
(_, failure2) <- expectPackageFailed plan2 pkgidP
(plan2, res2) <- executePlan
=<< planProject testdir (config <> keepGoing True)
(_, failure2) <- expectPackageFailed plan2 res2 pkgidP
expectBuildFailed failure2
_ <- expectPackageInstalled plan2 pkgidQ
_ <- expectPackageInstalled plan2 res2 pkgidQ
return ()
where
testdir = "build/keep-going"
......@@ -193,17 +191,17 @@ testBuildKeepGoing config = do
testRegressionIssue3324 :: ProjectConfig -> Assertion
testRegressionIssue3324 config = do
-- expected failure first time due to missing dep
plan1 <- executePlan =<< planProject testdir config
(_pkgq, failure) <- expectPackageFailed plan1 pkgidQ
(plan1, res1) <- executePlan =<< planProject testdir config
(_pkgq, failure) <- expectPackageFailed plan1 res1 pkgidQ
expectBuildFailed failure
-- add the missing dep, now it should work
let qcabal = basedir </> testdir </> "q" </> "q.cabal"
withFileFinallyRestore qcabal $ do
appendFile qcabal (" build-depends: p\n")
plan2 <- executePlan =<< planProject testdir config
_ <- expectPackageInstalled plan2 pkgidP
_ <- expectPackageInstalled plan2 pkgidQ
(plan2, res2) <- executePlan =<< planProject testdir config
_ <- expectPackageInstalled plan2 res2 pkgidP
_ <- expectPackageInstalled plan2 res2 pkgidQ
return ()
where
testdir = "regression/3324"
......@@ -238,7 +236,7 @@ planProject testdir cliConfig = do
let targets =
Map.fromList
[ (installedPackageId pkg, [BuildDefaultComponents])
[ (installedUnitId pkg, [BuildDefaultComponents])
| InstallPlan.Configured pkg <- InstallPlan.toList elaboratedPlan
, pkgBuildStyle pkg == BuildInplaceOnly ]
elaboratedPlan' = pruneInstallPlanToTargets targets elaboratedPlan
......@@ -265,12 +263,13 @@ type PlanDetails = (DistDirLayout,
BuildStatusMap,
BuildTimeSettings)
executePlan :: PlanDetails -> IO ElaboratedInstallPlan
executePlan :: PlanDetails -> IO (ElaboratedInstallPlan, BuildResults)
executePlan (distDirLayout,
elaboratedPlan,
elaboratedShared,
pkgsBuildStatus,
buildSettings) =
fmap ((,) elaboratedPlan) $
rebuildTargets verbosity
distDirLayout
elaboratedPlan
......@@ -341,66 +340,55 @@ expectException expected action = do
Left e -> return e
Right _ -> throwIO $ HUnitFailure $ "expected an exception " ++ expected
expectPackagePreExisting :: ElaboratedInstallPlan -> PackageId
expectPackagePreExisting :: ElaboratedInstallPlan -> BuildResults -> PackageId
-> IO InstalledPackageInfo
expectPackagePreExisting plan pkgid = do
expectPackagePreExisting plan buildResults pkgid = do
planpkg <- expectPlanPackage plan pkgid
case planpkg of
InstallPlan.PreExisting pkg
-> return pkg
_ -> unexpectedPackageState "PreExisting" planpkg
case (planpkg, InstallPlan.lookupBuildResult planpkg buildResults) of
(InstallPlan.PreExisting pkg, Nothing)
-> return pkg
(_, buildResult) -> unexpectedBuildResult "PreExisting" planpkg buildResult
expectPackageConfigured :: ElaboratedInstallPlan -> PackageId
expectPackageConfigured :: ElaboratedInstallPlan -> BuildResults -> PackageId
-> IO ElaboratedConfiguredPackage
expectPackageConfigured plan pkgid = do
expectPackageConfigured plan buildResults pkgid = do
planpkg <- expectPlanPackage plan pkgid
case planpkg of
InstallPlan.Configured pkg
-> return pkg
_ -> unexpectedPackageState "Configured" planpkg
expectPackageProcessing :: ElaboratedInstallPlan -> PackageId
-> IO ElaboratedConfiguredPackage
expectPackageProcessing plan pkgid = do
case (planpkg, InstallPlan.lookupBuildResult planpkg buildResults) of
(InstallPlan.Configured pkg, Nothing)
-> return pkg
(_, buildResult) -> unexpectedBuildResult "Configured" planpkg buildResult
expectPackageInstalled :: ElaboratedInstallPlan -> BuildResults -> PackageId
-> IO (ElaboratedConfiguredPackage, BuildSuccess)
expectPackageInstalled plan buildResults pkgid = do
planpkg <- expectPlanPackage plan pkgid
case planpkg of
InstallPlan.Processing (ReadyPackage pkg)
-> return pkg
_ -> unexpectedPackageState "Processing" planpkg
expectPackageInstalled :: ElaboratedInstallPlan -> PackageId
-> IO (ElaboratedConfiguredPackage,
Maybe InstalledPackageInfo,
BuildSuccess)
expectPackageInstalled plan pkgid = do
case (planpkg, InstallPlan.lookupBuildResult planpkg buildResults) of
(InstallPlan.Configured pkg, Just (Right result))
-> return (pkg, result)
(_, buildResult) -> unexpectedBuildResult "Installed" planpkg buildResult
expectPackageFailed :: ElaboratedInstallPlan -> BuildResults -> PackageId
-> IO (ElaboratedConfiguredPackage, BuildFailure)
expectPackageFailed plan buildResults pkgid = do
planpkg <- expectPlanPackage plan pkgid
case planpkg of
InstallPlan.Installed (ReadyPackage pkg) mipkg result
-> return (pkg, mipkg, result)
_ -> unexpectedPackageState "Installed" planpkg
expectPackageFailed :: ElaboratedInstallPlan -> PackageId
-> IO (ElaboratedConfiguredPackage,
BuildFailure)
expectPackageFailed plan pkgid = do
planpkg <- expectPlanPackage plan pkgid
case planpkg of
InstallPlan.Failed pkg failure
-> return (pkg, failure)
_ -> unexpectedPackageState "Failed" planpkg
unexpectedPackageState :: String -> ElaboratedPlanPackage -> IO a
unexpectedPackageState expected planpkg =
case (planpkg, InstallPlan.lookupBuildResult planpkg buildResults) of
(InstallPlan.Configured pkg, Just (Left failure))
-> return (pkg, failure)
(_, buildResult) -> unexpectedBuildResult "Failed" planpkg buildResult
unexpectedBuildResult :: String -> ElaboratedPlanPackage
-> Maybe (Either BuildFailure BuildSuccess) -> IO a
unexpectedBuildResult expected planpkg buildResult =
throwIO $ HUnitFailure $
"expected to find " ++ display (packageId planpkg) ++ " in the "
++ expected ++ " state, but it is actually in the " ++ actual ++ " state."
where
actual = case planpkg of
InstallPlan.PreExisting{} -> "PreExisting"
InstallPlan.Configured{} -> "Configured"
InstallPlan.Processing{} -> "Processing"
InstallPlan.Installed{} -> "Installed"
InstallPlan.Failed{} -> "Failed"
actual = case (buildResult, planpkg) of
(Nothing, InstallPlan.PreExisting{}) -> "PreExisting"
(Nothing, InstallPlan.Configured{}) -> "Configured"
(Just (Right _), InstallPlan.Configured{}) -> "Installed"
(Just (Left _), InstallPlan.Configured{}) -> "Failed"
_ -> "Impossible!"
expectPlanPackage :: ElaboratedInstallPlan -> PackageId
-> IO ElaboratedPlanPackage
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment