Commit f1c84021 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Move improveInstallPlanWithUpToDatePackages out of rebuildTargetsDryRun

Instead rebuildTargetsDryRun will just return the BuildStatusMap and
runProjectPreBuildPhase in ProjectOrchestration will compose things by
calling improveInstallPlanWithUpToDatePackages.

This is just a slight shifting of functionality from here to there, but
better reflects responsibilities. This is also slightly with a future
status command in mind which likely only needs the BuildStatusMap.

Also adjust the tests after changing type of rebuildTargetsDryRun.
parent 3ba96c1d
......@@ -260,27 +260,18 @@ buildStatusRequiresBuild _ = True
-- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'.
--
-- It gives us the 'BuildStatusMap' and also gives us an improved version of
-- It gives us the 'BuildStatusMap'. This should be used with
-- 'improveInstallPlanWithUpToDatePackages' to give an improved version of
-- the 'ElaboratedInstallPlan' with packages switched to the
-- 'InstallPlan.Installed' state when we find that they're already up to date.
--
rebuildTargetsDryRun :: Verbosity
-> DistDirLayout
rebuildTargetsDryRun :: DistDirLayout
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> IO (ElaboratedInstallPlan, BuildStatusMap)
rebuildTargetsDryRun verbosity distDirLayout@DistDirLayout{..} shared = \installPlan -> do
-> IO BuildStatusMap
rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =
-- Do the various checks to work out the 'BuildStatus' of each package
pkgsBuildStatus <- foldMInstallPlanDepOrder installPlan dryRunPkg
-- For 'BuildStatusUpToDate' packages, improve the plan by marking them as
-- 'InstallPlan.Installed'.
let installPlan' = improveInstallPlanWithUpToDatePackages
pkgsBuildStatus installPlan
debugNoWrap verbosity $ InstallPlan.showInstallPlan installPlan'
return (installPlan', pkgsBuildStatus)
foldMInstallPlanDepOrder dryRunPkg
where
dryRunPkg :: ElaboratedPlanPackage
-> [BuildStatus]
......@@ -362,12 +353,12 @@ rebuildTargetsDryRun verbosity distDirLayout@DistDirLayout{..} shared = \install
foldMInstallPlanDepOrder
:: forall m ipkg srcpkg b.
(Monad m, IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> (GenericPlanPackage ipkg srcpkg ->
=> (GenericPlanPackage ipkg srcpkg ->
[b] -> m b)
-> GenericInstallPlan ipkg srcpkg
-> m (Map UnitId b)
foldMInstallPlanDepOrder plan0 visit =
go Map.empty (InstallPlan.reverseTopologicalOrder plan0)
foldMInstallPlanDepOrder visit =
go Map.empty . InstallPlan.reverseTopologicalOrder
where
go :: Map UnitId b
-> [GenericPlanPackage ipkg srcpkg]
......
......@@ -84,7 +84,7 @@ import Distribution.Simple.Command (commandShowOptions)
import Distribution.Simple.Utils
( die, dieMsg, dieMsgNoWrap, info
, notice, noticeNoWrap, debug )
, notice, noticeNoWrap, debug, debugNoWrap )
import Distribution.Verbosity
import Distribution.Text
......@@ -188,12 +188,17 @@ runProjectPreBuildPhase
--
elaboratedPlan' <- hookSelectPlanSubset buildSettings elaboratedPlan
-- Check if any packages don't need rebuilding, and improve the plan.
-- Check which packages need rebuilding.
-- This also gives us more accurate reasons for the --dry-run output.
--
(elaboratedPlan'', pkgsBuildStatus) <-
rebuildTargetsDryRun verbosity distDirLayout elaboratedShared
elaboratedPlan'
pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared
elaboratedPlan'
-- Improve the plan by marking up-to-date packages as installed.
--
let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages
pkgsBuildStatus elaboratedPlan'
debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'')
return ProjectBuildContext {
projectRootDir,
......
......@@ -256,10 +256,13 @@ planProject testdir cliConfig = do
, elabBuildStyle elab == BuildInplaceOnly ]
elaboratedPlan' = pruneInstallPlanToTargets targets elaboratedPlan
(elaboratedPlan'', pkgsBuildStatus) <-
rebuildTargetsDryRun verbosity distDirLayout elaboratedShared
pkgsBuildStatus <-
rebuildTargetsDryRun distDirLayout elaboratedShared
elaboratedPlan'
let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages
pkgsBuildStatus elaboratedPlan'
let buildSettings = resolveBuildTimeSettings
verbosity cabalDirLayout
(projectConfigShared projectConfig)
......
Markdown is supported
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