Commit 2d6f94ea authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Add InstallPlan.executionOrder

This is a replacement for the existing linearizeInstallPlan utils.
It uses the new separate traversal approach.
parent 4d09392f
......@@ -38,6 +38,8 @@ module Distribution.Client.InstallPlan (
preinstalled,
-- * Traversal
executionOrder,
-- ** Traversal helpers
-- $traversal
Processing,
ready',
......@@ -574,6 +576,14 @@ stateDependencyRelation _ _ = False
-- | Return all the packages in the 'InstallPlan' in reverse topological order.
-- That is, for each package, all depencencies of the package appear first.
--
-- Compared to 'executionOrder', this function returns all the installed and
-- source packages rather than just the source ones. Also, while both this
-- and 'executionOrder' produce reverse topological orderings of the package
-- dependency graph, it is not necessarily exactly the same order.
--
reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg iresult ifailure
-> [GenericPlanPackage ipkg srcpkg iresult ifailure]
reverseTopologicalOrder plan = Graph.revTopSort (planIndex plan)
......@@ -832,3 +842,29 @@ processingInvariant plan (Processing' processingSet completedSet failedSet) =
. Set.toList
$ processingSet
noIntersection a b = Set.null (Set.intersection a b)
-- | Flatten an 'InstallPlan', producing the sequence of source packages in
-- the order in which they would be processed when the plan is executed. This
-- can be used for simultations or presenting execution dry-runs.
--
-- It is guaranteed to give the same order as using 'execute' (with a serial
-- in-order 'JobControl'), which is a reverse topological orderings of the
-- source packages in the dependency graph, albeit not necessarily exactly the
-- same ordering as that produced by 'reverseTopologicalOrder'.
--
executionOrder :: (HasUnitId ipkg, PackageFixedDeps ipkg,
HasUnitId srcpkg, PackageFixedDeps srcpkg)
=> GenericInstallPlan ipkg srcpkg unused1 unused2
-> [GenericReadyPackage srcpkg]
executionOrder plan =
let (newpkgs, processing) = ready' plan
in tryNewTasks processing newpkgs
where
tryNewTasks _processing [] = []
tryNewTasks processing (p:todo) = waitForTasks processing p todo
waitForTasks processing p todo =
p : tryNewTasks processing' (todo++nextpkgs)
where
(nextpkgs, processing') = completed' plan processing (installedUnitId p)
......@@ -13,6 +13,8 @@ import Data.Graph
import Data.Array hiding (index)
import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Set (Set)
import Control.Monad
import Test.QuickCheck
......@@ -23,6 +25,7 @@ import Test.Tasty.QuickCheck
tests :: [TestTree]
tests =
[ testProperty "reverseTopologicalOrder" prop_reverseTopologicalOrder
, testProperty "executionOrder" prop_executionOrder
]
prop_reverseTopologicalOrder :: TestInstallPlan -> Bool
......@@ -32,6 +35,12 @@ prop_reverseTopologicalOrder (TestInstallPlan plan graph toVertex _) =
(map (toVertex . installedUnitId)
(InstallPlan.reverseTopologicalOrder plan))
prop_executionOrder :: TestInstallPlan -> Bool
prop_executionOrder (TestInstallPlan plan graph toVertex _) =
isReversePartialTopologicalOrder graph (map toVertex pkgids)
&& allConfiguredPackages plan == Set.fromList pkgids
where
pkgids = map installedUnitId (InstallPlan.executionOrder plan)
--------------------------
-- Property helper utils
......@@ -50,6 +59,23 @@ isReverseTopologicalOrder g vs =
| let ixs = array (bounds g) (zip vs [0::Int ..])
, (u,v) <- edges g ]
isReversePartialTopologicalOrder :: Graph -> [Vertex] -> Bool
isReversePartialTopologicalOrder g vs =
and [ case (ixs ! u, ixs ! v) of
(Just ixu, Just ixv) -> ixu > ixv
_ -> True
| let ixs = array (bounds g)
(zip (range (bounds g)) (repeat Nothing) ++
zip vs (map Just [0::Int ..]))
, (u,v) <- edges g ]
allConfiguredPackages :: HasUnitId srcpkg
=> GenericInstallPlan ipkg srcpkg unused1 unused2 -> Set UnitId
allConfiguredPackages plan =
Set.fromList
[ installedUnitId pkg
| InstallPlan.Configured pkg <- InstallPlan.toList plan ]
--------------------
-- Test generators
......
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