Commit 66ed37a2 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Refactor implementation of InstallPlan.installed

All the use sites (currently only two but soon to be three) use
InstallPlan.installed to do a bulk change of states, differing only in
the filter condition. So it simplifies things and shares more code if
we make the main one be the bulk version. The InstallPlan.remove already
works similarly.
parent 5584569c
......@@ -290,24 +290,27 @@ remove shouldRemove plan =
newIndex = Graph.fromList $
filter (not . shouldRemove) (toList plan)
-- | Change a package in a 'Configured' state to an 'Installed' state.
-- | Change a number of packages in the 'Configured' state to the 'Installed'
-- state.
--
-- To preserve invariants, the package must have all of its dependencies
-- already installed too (that is 'PreExisting' or 'Installed').
--
installed :: (IsUnit ipkg,
IsUnit srcpkg)
=> UnitId
installed :: (IsUnit ipkg, IsUnit srcpkg)
=> (srcpkg -> Bool)
-> GenericInstallPlan ipkg srcpkg
-> GenericInstallPlan ipkg srcpkg
installed pkgid plan =
case lookup plan pkgid of
Just (Configured srcpkg) ->
assert (all isInstalled (directDeps plan pkgid)) $
plan {
planIndex = Graph.insert (Installed srcpkg) (planIndex plan)
}
_ -> error "InstallPlan.installed: unexpected state"
installed shouldBeInstalled installPlan =
foldl' markInstalled installPlan
[ pkg
| Configured pkg <- reverseTopologicalOrder installPlan
, shouldBeInstalled pkg ]
where
markInstalled plan pkg =
assert (all isInstalled (directDeps plan (nodeKey pkg))) $
plan {
planIndex = Graph.insert (Installed pkg) (planIndex plan)
}
-- | Lookup a package in the plan.
--
......
......@@ -257,7 +257,7 @@ rebuildTargetsDryRun verbosity distDirLayout@DistDirLayout{..} shared = \install
-- For 'BuildStatusUpToDate' packages, improve the plan by marking them as
-- 'InstallPlan.Installed'.
let installPlan' = improveInstallPlanWithUpToDatePackages
installPlan pkgsBuildStatus
pkgsBuildStatus installPlan
debugNoWrap verbosity $ InstallPlan.showInstallPlan installPlan'
return (installPlan', pkgsBuildStatus)
......@@ -365,24 +365,18 @@ foldMInstallPlanDepOrder plan0 visit =
let results' = Map.insert (nodeKey pkg) result results
go results' pkgs
improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan
-> BuildStatusMap
improveInstallPlanWithUpToDatePackages :: BuildStatusMap
-> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus =
replaceWithInstalled installPlan
[ installedUnitId pkg
| InstallPlan.Configured pkg
<- InstallPlan.reverseTopologicalOrder installPlan
, case Map.lookup (installedUnitId pkg) pkgsBuildStatus of
Just BuildStatusUpToDate {} -> True
Just _ -> False
Nothing -> error "improveInstallPlanWithUpToDatePackages: impossible"
]
-> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages pkgsBuildStatus =
InstallPlan.installed canPackageBeImproved
where
replaceWithInstalled :: ElaboratedInstallPlan -> [UnitId]
-> ElaboratedInstallPlan
replaceWithInstalled =
foldl' (flip InstallPlan.installed)
canPackageBeImproved pkg =
case Map.lookup (installedUnitId pkg) pkgsBuildStatus of
Just BuildStatusUpToDate {} -> True
Just _ -> False
Nothing -> error $ "improveInstallPlanWithUpToDatePackages: "
++ display (packageId pkg) ++ " not in status map"
-----------------------------
......
......@@ -2723,13 +2723,11 @@ packageHashConfigInputs
improveInstallPlanWithInstalledPackages :: Set UnitId
-> ElaboratedInstallPlan
-> ElaboratedInstallPlan
improveInstallPlanWithInstalledPackages installedPkgIdSet installPlan =
replaceWithInstalled installPlan
[ installedUnitId pkg
| InstallPlan.Configured pkg
<- InstallPlan.reverseTopologicalOrder installPlan
, canPackageBeImproved pkg ]
improveInstallPlanWithInstalledPackages installedPkgIdSet =
InstallPlan.installed canPackageBeImproved
where
canPackageBeImproved pkg =
installedUnitId pkg `Set.member` installedPkgIdSet
--TODO: sanity checks:
-- * the installed package must have the expected deps etc
-- * the installed package must not be broken, valid dep closure
......@@ -2737,9 +2735,3 @@ improveInstallPlanWithInstalledPackages installedPkgIdSet installPlan =
--TODO: decide what to do if we encounter broken installed packages,
-- since overwriting is never safe.
canPackageBeImproved pkg =
installedUnitId pkg `Set.member` installedPkgIdSet
replaceWithInstalled :: ElaboratedInstallPlan -> [UnitId]
-> ElaboratedInstallPlan
replaceWithInstalled = foldl' (flip InstallPlan.installed)
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