Commit d5288df0 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 bf0b5dfe
...@@ -290,24 +290,27 @@ remove shouldRemove plan = ...@@ -290,24 +290,27 @@ remove shouldRemove plan =
newIndex = Graph.fromList $ newIndex = Graph.fromList $
filter (not . shouldRemove) (toList plan) 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 -- To preserve invariants, the package must have all of its dependencies
-- already installed too (that is 'PreExisting' or 'Installed'). -- already installed too (that is 'PreExisting' or 'Installed').
-- --
installed :: (IsUnit ipkg, installed :: (IsUnit ipkg, IsUnit srcpkg)
IsUnit srcpkg) => (srcpkg -> Bool)
=> UnitId
-> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg
-> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg
installed pkgid plan = installed shouldBeInstalled installPlan =
case lookup plan pkgid of foldl' markInstalled installPlan
Just (Configured srcpkg) -> [ pkg
assert (all isInstalled (directDeps plan pkgid)) $ | Configured pkg <- reverseTopologicalOrder installPlan
plan { , shouldBeInstalled pkg ]
planIndex = Graph.insert (Installed srcpkg) (planIndex plan) where
} markInstalled plan pkg =
_ -> error "InstallPlan.installed: unexpected state" assert (all isInstalled (directDeps plan (nodeKey pkg))) $
plan {
planIndex = Graph.insert (Installed pkg) (planIndex plan)
}
-- | Lookup a package in the plan. -- | Lookup a package in the plan.
-- --
......
...@@ -257,7 +257,7 @@ rebuildTargetsDryRun verbosity distDirLayout@DistDirLayout{..} shared = \install ...@@ -257,7 +257,7 @@ rebuildTargetsDryRun verbosity distDirLayout@DistDirLayout{..} shared = \install
-- For 'BuildStatusUpToDate' packages, improve the plan by marking them as -- For 'BuildStatusUpToDate' packages, improve the plan by marking them as
-- 'InstallPlan.Installed'. -- 'InstallPlan.Installed'.
let installPlan' = improveInstallPlanWithUpToDatePackages let installPlan' = improveInstallPlanWithUpToDatePackages
installPlan pkgsBuildStatus pkgsBuildStatus installPlan
debugNoWrap verbosity $ InstallPlan.showInstallPlan installPlan' debugNoWrap verbosity $ InstallPlan.showInstallPlan installPlan'
return (installPlan', pkgsBuildStatus) return (installPlan', pkgsBuildStatus)
...@@ -365,24 +365,18 @@ foldMInstallPlanDepOrder plan0 visit = ...@@ -365,24 +365,18 @@ foldMInstallPlanDepOrder plan0 visit =
let results' = Map.insert (nodeKey pkg) result results let results' = Map.insert (nodeKey pkg) result results
go results' pkgs go results' pkgs
improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan improveInstallPlanWithUpToDatePackages :: BuildStatusMap
-> BuildStatusMap
-> ElaboratedInstallPlan -> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus = -> ElaboratedInstallPlan
replaceWithInstalled installPlan improveInstallPlanWithUpToDatePackages pkgsBuildStatus =
[ installedUnitId pkg InstallPlan.installed canPackageBeImproved
| InstallPlan.Configured pkg
<- InstallPlan.reverseTopologicalOrder installPlan
, case Map.lookup (installedUnitId pkg) pkgsBuildStatus of
Just BuildStatusUpToDate {} -> True
Just _ -> False
Nothing -> error "improveInstallPlanWithUpToDatePackages: impossible"
]
where where
replaceWithInstalled :: ElaboratedInstallPlan -> [UnitId] canPackageBeImproved pkg =
-> ElaboratedInstallPlan case Map.lookup (installedUnitId pkg) pkgsBuildStatus of
replaceWithInstalled = Just BuildStatusUpToDate {} -> True
foldl' (flip InstallPlan.installed) Just _ -> False
Nothing -> error $ "improveInstallPlanWithUpToDatePackages: "
++ display (packageId pkg) ++ " not in status map"
----------------------------- -----------------------------
......
...@@ -2705,13 +2705,11 @@ packageHashConfigInputs ...@@ -2705,13 +2705,11 @@ packageHashConfigInputs
improveInstallPlanWithInstalledPackages :: Set UnitId improveInstallPlanWithInstalledPackages :: Set UnitId
-> ElaboratedInstallPlan -> ElaboratedInstallPlan
-> ElaboratedInstallPlan -> ElaboratedInstallPlan
improveInstallPlanWithInstalledPackages installedPkgIdSet installPlan = improveInstallPlanWithInstalledPackages installedPkgIdSet =
replaceWithInstalled installPlan InstallPlan.installed canPackageBeImproved
[ installedUnitId pkg
| InstallPlan.Configured pkg
<- InstallPlan.reverseTopologicalOrder installPlan
, canPackageBeImproved pkg ]
where where
canPackageBeImproved pkg =
installedUnitId pkg `Set.member` installedPkgIdSet
--TODO: sanity checks: --TODO: sanity checks:
-- * the installed package must have the expected deps etc -- * the installed package must have the expected deps etc
-- * the installed package must not be broken, valid dep closure -- * the installed package must not be broken, valid dep closure
...@@ -2719,9 +2717,3 @@ improveInstallPlanWithInstalledPackages installedPkgIdSet installPlan = ...@@ -2719,9 +2717,3 @@ improveInstallPlanWithInstalledPackages installedPkgIdSet installPlan =
--TODO: decide what to do if we encounter broken installed packages, --TODO: decide what to do if we encounter broken installed packages,
-- since overwriting is never safe. -- 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