Commit ff6c718b authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Switch InstallPlan over to using IPID-indexed PackageIndex.

While this doesn't let us get rid of Distribution.Client.PackageIndex,
it does make InstallPlan more flexible, so we can have the same
package name-package version in the install plan multiple times.
We do this by synthesizing fake installed package IDs to act
as placeholders prior to compilation.

There is some shindig with 'FakeMap' in PackageIndex, check out
the Note in that file for more details.

This reverts commit a5a0f8e1959003ee702c04a23375a60d48f03f90, with
a bugfix for linearizeInstallPlan.

Fixes #2123
parent 90993d34
...@@ -16,6 +16,7 @@ module Distribution.Simple.PackageIndex ( ...@@ -16,6 +16,7 @@ module Distribution.Simple.PackageIndex (
-- * Package index data type -- * Package index data type
InstalledPackageIndex, InstalledPackageIndex,
PackageIndex, PackageIndex,
FakeMap,
-- * Creating an index -- * Creating an index
fromList, fromList,
...@@ -59,6 +60,15 @@ module Distribution.Simple.PackageIndex ( ...@@ -59,6 +60,15 @@ module Distribution.Simple.PackageIndex (
dependencyCycles, dependencyCycles,
dependencyGraph, dependencyGraph,
moduleNameIndex, moduleNameIndex,
-- ** Variants of special queries supporting fake map
fakeLookupInstalledPackageId,
brokenPackages',
dependencyClosure',
reverseDependencyClosure',
dependencyInconsistencies',
dependencyCycles',
dependencyGraph',
) where ) where
import Control.Exception (assert) import Control.Exception (assert)
...@@ -91,6 +101,40 @@ import Distribution.Version ...@@ -91,6 +101,40 @@ import Distribution.Version
( Version, withinRange ) ( Version, withinRange )
import Distribution.Simple.Utils (lowercase, comparing, equating) import Distribution.Simple.Utils (lowercase, comparing, equating)
-- Note [FakeMap]
-----------------
-- We'd like to use the PackageIndex defined in this module for
-- cabal-install's InstallPlan. However, at the moment, this
-- data structure is indexed by InstalledPackageId, which we don't
-- know until after we've compiled a package (whereas InstallPlan
-- needs to store not-compiled packages in the index.) Eventually,
-- an InstalledPackageId will be calculatable prior to actually
-- building the package (making it something of a misnomer), but
-- at the moment, the "fake installed package ID map" is a workaround
-- to solve this problem while reusing PackageIndex. The basic idea
-- is that, since we don't know what an InstalledPackageId is
-- beforehand, we just fake up one based on the package ID (it only
-- needs to be unique for the particular install plan), and fill
-- it out with the actual generated InstalledPackageId after the
-- package is successfully compiled.
--
-- However, there is a problem: in the index there may be
-- references using the old package ID, which are now dangling if
-- we update the InstalledPackageId. We could map over the entire
-- index to update these pointers as well (a costly operation), but
-- instead, we've chosen to parametrize a variety of important functions
-- by a FakeMap, which records what a fake installed package ID was
-- actually resolved to post-compilation. If we do a lookup, we first
-- check and see if it's a fake ID in the FakeMap.
--
-- It's a bit grungy, but we expect this to only be temporary anyway.
-- (Another possible workaround would have been to *not* update
-- the installed package ID, but I decided this would be hard to
-- understand.)
-- | Map from fake installed package IDs to real ones. See Note [FakeMap]
type FakeMap = Map InstalledPackageId InstalledPackageId
-- | The collection of information about packages from one or more 'PackageDB's. -- | The collection of information about packages from one or more 'PackageDB's.
-- These packages generally should have an instance of 'PackageInstalled' -- These packages generally should have an instance of 'PackageInstalled'
-- --
...@@ -203,7 +247,7 @@ fromList pkgs = mkPackageIndex pids pnames ...@@ -203,7 +247,7 @@ fromList pkgs = mkPackageIndex pids pnames
-- --
merge :: PackageInstalled a => PackageIndex a -> PackageIndex a -> PackageIndex a merge :: PackageInstalled a => PackageIndex a -> PackageIndex a -> PackageIndex a
merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) =
mkPackageIndex (Map.union pids1 pids2) mkPackageIndex (Map.unionWith (\_ y -> y) pids1 pids2)
(Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2)
where where
-- Packages in the second list mask those in the first, however preferred -- Packages in the second list mask those in the first, however preferred
...@@ -444,10 +488,14 @@ searchByNameSubstring (PackageIndex _ pnames) searchterm = ...@@ -444,10 +488,14 @@ searchByNameSubstring (PackageIndex _ pnames) searchterm =
-- other, directly or indirectly. -- other, directly or indirectly.
-- --
dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]] dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]]
dependencyCycles index = dependencyCycles = dependencyCycles' Map.empty
-- | Variant of 'dependencyCycles' which accepts a 'FakeMap'. See Note [FakeMap].
dependencyCycles' :: PackageInstalled a => FakeMap -> PackageIndex a -> [[a]]
dependencyCycles' fakeMap index =
[ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]
where where
adjacencyList = [ (pkg, installedPackageId pkg, installedDepends pkg) adjacencyList = [ (pkg, installedPackageId pkg, fakeInstalledDepends fakeMap pkg)
| pkg <- allPackages index ] | pkg <- allPackages index ]
...@@ -456,13 +504,20 @@ dependencyCycles index = ...@@ -456,13 +504,20 @@ dependencyCycles index =
-- Returns such packages along with the dependencies that they're missing. -- Returns such packages along with the dependencies that they're missing.
-- --
brokenPackages :: PackageInstalled a => PackageIndex a -> [(a, [InstalledPackageId])] brokenPackages :: PackageInstalled a => PackageIndex a -> [(a, [InstalledPackageId])]
brokenPackages index = brokenPackages = brokenPackages' Map.empty
-- | Variant of 'brokenPackages' which accepts a 'FakeMap'. See Note [FakeMap].
brokenPackages' :: PackageInstalled a => FakeMap -> PackageIndex a -> [(a, [InstalledPackageId])]
brokenPackages' fakeMap index =
[ (pkg, missing) [ (pkg, missing)
| pkg <- allPackages index | pkg <- allPackages index
, let missing = [ pkg' | pkg' <- installedDepends pkg , let missing = [ pkg' | pkg' <- installedDepends pkg
, isNothing (lookupInstalledPackageId index pkg') ] , isNothing (fakeLookupInstalledPackageId fakeMap index pkg') ]
, not (null missing) ] , not (null missing) ]
-- | Variant of 'lookupInstalledPackageId' which accepts a 'FakeMap'. See Note [FakeMap].
fakeLookupInstalledPackageId :: PackageInstalled a => FakeMap -> PackageIndex a -> InstalledPackageId -> Maybe a
fakeLookupInstalledPackageId fakeMap index pkg = lookupInstalledPackageId index (Map.findWithDefault pkg pkg fakeMap)
-- | Tries to take the transitive closure of the package dependencies. -- | Tries to take the transitive closure of the package dependencies.
-- --
...@@ -476,14 +531,22 @@ dependencyClosure :: PackageInstalled a => PackageIndex a ...@@ -476,14 +531,22 @@ dependencyClosure :: PackageInstalled a => PackageIndex a
-> [InstalledPackageId] -> [InstalledPackageId]
-> Either (PackageIndex a) -> Either (PackageIndex a)
[(a, [InstalledPackageId])] [(a, [InstalledPackageId])]
dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of dependencyClosure = dependencyClosure' Map.empty
-- | Variant of 'dependencyClosure' which accepts a 'FakeMap'. See Note [FakeMap].
dependencyClosure' :: PackageInstalled a => FakeMap
-> PackageIndex a
-> [InstalledPackageId]
-> Either (PackageIndex a)
[(a, [InstalledPackageId])]
dependencyClosure' fakeMap index pkgids0 = case closure mempty [] pkgids0 of
(completed, []) -> Left completed (completed, []) -> Left completed
(completed, _) -> Right (brokenPackages completed) (completed, _) -> Right (brokenPackages completed)
where where
closure completed failed [] = (completed, failed) closure completed failed [] = (completed, failed)
closure completed failed (pkgid:pkgids) = case lookupInstalledPackageId index pkgid of closure completed failed (pkgid:pkgids) = case fakeLookupInstalledPackageId fakeMap index pkgid of
Nothing -> closure completed (pkgid:failed) pkgids Nothing -> closure completed (pkgid:failed) pkgids
Just pkg -> case lookupInstalledPackageId completed (installedPackageId pkg) of Just pkg -> case fakeLookupInstalledPackageId fakeMap completed (installedPackageId pkg) of
Just _ -> closure completed failed pkgids Just _ -> closure completed failed pkgids
Nothing -> closure completed' failed pkgids' Nothing -> closure completed' failed pkgids'
where completed' = insert pkg completed where completed' = insert pkg completed
...@@ -496,14 +559,21 @@ dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of ...@@ -496,14 +559,21 @@ dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of
reverseDependencyClosure :: PackageInstalled a => PackageIndex a reverseDependencyClosure :: PackageInstalled a => PackageIndex a
-> [InstalledPackageId] -> [InstalledPackageId]
-> [a] -> [a]
reverseDependencyClosure index = reverseDependencyClosure = reverseDependencyClosure' Map.empty
-- | Variant of 'reverseDependencyClosure' which accepts a 'FakeMap'. See Note [FakeMap].
reverseDependencyClosure' :: PackageInstalled a => FakeMap
-> PackageIndex a
-> [InstalledPackageId]
-> [a]
reverseDependencyClosure' fakeMap index =
map vertexToPkg map vertexToPkg
. concatMap Tree.flatten . concatMap Tree.flatten
. Graph.dfs reverseDepGraph . Graph.dfs reverseDepGraph
. map (fromMaybe noSuchPkgId . pkgIdToVertex) . map (fromMaybe noSuchPkgId . pkgIdToVertex)
where where
(depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph' fakeMap index
reverseDepGraph = Graph.transposeG depGraph reverseDepGraph = Graph.transposeG depGraph
noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" noSuchPkgId = error "reverseDependencyClosure: package is not in the graph"
...@@ -529,7 +599,15 @@ dependencyGraph :: PackageInstalled a => PackageIndex a ...@@ -529,7 +599,15 @@ dependencyGraph :: PackageInstalled a => PackageIndex a
-> (Graph.Graph, -> (Graph.Graph,
Graph.Vertex -> a, Graph.Vertex -> a,
InstalledPackageId -> Maybe Graph.Vertex) InstalledPackageId -> Maybe Graph.Vertex)
dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex) dependencyGraph = dependencyGraph' Map.empty
-- | Variant of 'dependencyGraph' which accepts a 'FakeMap'. See Note [FakeMap].
dependencyGraph' :: PackageInstalled a => FakeMap
-> PackageIndex a
-> (Graph.Graph,
Graph.Vertex -> a,
InstalledPackageId -> Maybe Graph.Vertex)
dependencyGraph' fakeMap index = (graph, vertex_to_pkg, id_to_vertex)
where where
graph = Array.listArray bounds graph = Array.listArray bounds
[ [ v | Just v <- map id_to_vertex (installedDepends pkg) ] [ [ v | Just v <- map id_to_vertex (installedDepends pkg) ]
...@@ -538,7 +616,7 @@ dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex) ...@@ -538,7 +616,7 @@ dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex)
pkgs = sortBy (comparing packageId) (allPackages index) pkgs = sortBy (comparing packageId) (allPackages index)
vertices = zip (map installedPackageId pkgs) [0..] vertices = zip (map installedPackageId pkgs) [0..]
vertex_map = Map.fromList vertices vertex_map = Map.fromList vertices
id_to_vertex pid = Map.lookup pid vertex_map id_to_vertex pid = Map.lookup (Map.findWithDefault pid pid fakeMap) vertex_map
vertex_to_pkg vertex = pkgTable ! vertex vertex_to_pkg vertex = pkgTable ! vertex
...@@ -558,7 +636,12 @@ dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex) ...@@ -558,7 +636,12 @@ dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex)
-- --
dependencyInconsistencies :: PackageInstalled a => PackageIndex a dependencyInconsistencies :: PackageInstalled a => PackageIndex a
-> [(PackageName, [(PackageId, Version)])] -> [(PackageName, [(PackageId, Version)])]
dependencyInconsistencies index = dependencyInconsistencies = dependencyInconsistencies' Map.empty
-- | Variant of 'dependencyInconsistencies' which accepts a 'FakeMap'. See Note [FakeMap].
dependencyInconsistencies' :: PackageInstalled a => FakeMap -> PackageIndex a
-> [(PackageName, [(PackageId, Version)])]
dependencyInconsistencies' fakeMap index =
[ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids]) [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids])
| (name, ipid_map) <- Map.toList inverseIndex | (name, ipid_map) <- Map.toList inverseIndex
, let uses = Map.elems ipid_map , let uses = Map.elems ipid_map
...@@ -572,18 +655,23 @@ dependencyInconsistencies index = ...@@ -572,18 +655,23 @@ dependencyInconsistencies index =
[ (packageName dep, [ (packageName dep,
Map.fromList [(ipid,(dep,[packageId pkg]))]) Map.fromList [(ipid,(dep,[packageId pkg]))])
| pkg <- allPackages index | pkg <- allPackages index
, ipid <- installedDepends pkg , ipid <- fakeInstalledDepends fakeMap pkg
, Just dep <- [lookupInstalledPackageId index ipid] , Just dep <- [fakeLookupInstalledPackageId fakeMap index ipid]
] ]
reallyIsInconsistent :: PackageInstalled a => [a] -> Bool reallyIsInconsistent :: PackageInstalled a => [a] -> Bool
reallyIsInconsistent [] = False reallyIsInconsistent [] = False
reallyIsInconsistent [_p] = False reallyIsInconsistent [_p] = False
reallyIsInconsistent [p1, p2] = reallyIsInconsistent [p1, p2] =
installedPackageId p1 `notElem` installedDepends p2 let pid1 = installedPackageId p1
&& installedPackageId p2 `notElem` installedDepends p1 pid2 = installedPackageId p2
in Map.findWithDefault pid1 pid1 fakeMap `notElem` fakeInstalledDepends fakeMap p2
&& Map.findWithDefault pid2 pid2 fakeMap `notElem` fakeInstalledDepends fakeMap p1
reallyIsInconsistent _ = True reallyIsInconsistent _ = True
-- | Variant of 'installedDepends' which accepts a 'FakeMap'. See Note [FakeMap].
fakeInstalledDepends :: PackageInstalled a => FakeMap -> a -> [InstalledPackageId]
fakeInstalledDepends fakeMap = map (\pid -> Map.findWithDefault pid pid fakeMap) . installedDepends
-- | A rough approximation of GHC's module finder, takes a 'InstalledPackageIndex' and -- | A rough approximation of GHC's module finder, takes a 'InstalledPackageIndex' and
-- turns it into a map from module names to their source packages. It's used to -- turns it into a map from module names to their source packages. It's used to
......
...@@ -554,7 +554,7 @@ mkInstallPlan :: Platform ...@@ -554,7 +554,7 @@ mkInstallPlan :: Platform
-> CompilerId -> CompilerId
-> [InstallPlan.PlanPackage] -> InstallPlan -> [InstallPlan.PlanPackage] -> InstallPlan
mkInstallPlan platform comp pkgIndex = mkInstallPlan platform comp pkgIndex =
case InstallPlan.new platform comp (PackageIndex.fromList pkgIndex) of case InstallPlan.new platform comp (InstalledPackageIndex.fromList pkgIndex) of
Right plan -> plan Right plan -> plan
Left problems -> error $ unlines $ Left problems -> error $ unlines $
"internal error: could not construct a valid install plan." "internal error: could not construct a valid install plan."
......
...@@ -17,7 +17,7 @@ mkPlan :: Platform -> CompilerId -> ...@@ -17,7 +17,7 @@ mkPlan :: Platform -> CompilerId ->
SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage -> SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage ->
[CP QPN] -> Either [PlanProblem] InstallPlan [CP QPN] -> Either [PlanProblem] InstallPlan
mkPlan plat comp iidx sidx cps = mkPlan plat comp iidx sidx cps =
new plat comp (CI.fromList (map (convCP iidx sidx) cps)) new plat comp (SI.fromList (map (convCP iidx sidx) cps))
convCP :: SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage -> convCP :: SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage ->
CP QPN -> PlanPackage CP QPN -> PlanPackage
......
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
-- Module : Distribution.Client.Install -- Module : Distribution.Client.Install
...@@ -125,7 +126,7 @@ import Distribution.Simple.InstallDirs as InstallDirs ...@@ -125,7 +126,7 @@ import Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Package import Distribution.Package
( PackageIdentifier(..), PackageId, packageName, packageVersion ( PackageIdentifier(..), PackageId, packageName, packageVersion
, Package(..), PackageFixedDeps(..), PackageKey , Package(..), PackageFixedDeps(..), PackageKey
, Dependency(..), thisPackageVersion, InstalledPackageId ) , Dependency(..), thisPackageVersion, InstalledPackageId, installedPackageId )
import qualified Distribution.PackageDescription as PackageDescription import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription import Distribution.PackageDescription
( PackageDescription, GenericPackageDescription(..), Flag(..) ( PackageDescription, GenericPackageDescription(..), Flag(..)
...@@ -516,15 +517,18 @@ linearizeInstallPlan comp installedPkgIndex plan = ...@@ -516,15 +517,18 @@ linearizeInstallPlan comp installedPkgIndex plan =
[] -> Nothing [] -> Nothing
(pkg:_) -> Just ((pkg, status), plan'') (pkg:_) -> Just ((pkg, status), plan'')
where where
pkgid = packageId pkg pkgid = installedPackageId pkg
status = packageStatus comp installedPkgIndex pkg status = packageStatus comp installedPkgIndex pkg
plan'' = InstallPlan.completed pkgid plan'' = InstallPlan.completed pkgid
(BuildOk DocsNotTried TestsNotTried (BuildOk DocsNotTried TestsNotTried
(Just $ Installed.emptyInstalledPackageInfo (Just $ Installed.emptyInstalledPackageInfo
{ Installed.sourcePackageId = pkgid })) { Installed.sourcePackageId = packageId pkg
, Installed.installedPackageId = pkgid }))
(InstallPlan.processing [pkg] plan') (InstallPlan.processing [pkg] plan')
--FIXME: This is a bit of a hack, --FIXME: This is a bit of a hack,
-- pretending that each package is installed -- pretending that each package is installed
-- It's doubly a hack because the installed package ID
-- didn't get updated...
data PackageStatus = NewPackage data PackageStatus = NewPackage
| NewVersion [Version] | NewVersion [Version]
...@@ -1124,10 +1128,10 @@ executeInstallPlan verbosity comp jobCtl useLogFile plan0 installPkg = ...@@ -1124,10 +1128,10 @@ executeInstallPlan verbosity comp jobCtl useLogFile plan0 installPkg =
updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan -> InstallPlan updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan -> InstallPlan
updatePlan pkgid (Right buildSuccess) = updatePlan pkgid (Right buildSuccess) =
InstallPlan.completed pkgid buildSuccess InstallPlan.completed (Source.fakeInstalledPackageId pkgid) buildSuccess
updatePlan pkgid (Left buildFailure) = updatePlan pkgid (Left buildFailure) =
InstallPlan.failed pkgid buildFailure depsFailure InstallPlan.failed (Source.fakeInstalledPackageId pkgid) buildFailure depsFailure
where where
depsFailure = DependentFailed pkgid depsFailure = DependentFailed pkgid
-- So this first pkgid failed for whatever reason (buildFailure). -- So this first pkgid failed for whatever reason (buildFailure).
......
...@@ -49,10 +49,11 @@ import Distribution.Client.Types ...@@ -49,10 +49,11 @@ import Distribution.Client.Types
( SourcePackage(packageDescription), ConfiguredPackage(..) ( SourcePackage(packageDescription), ConfiguredPackage(..)
, ReadyPackage(..), readyPackageToConfiguredPackage , ReadyPackage(..), readyPackageToConfiguredPackage
, InstalledPackage, BuildFailure, BuildSuccess(..), enableStanzas , InstalledPackage, BuildFailure, BuildSuccess(..), enableStanzas
, InstalledPackage (..) ) , InstalledPackage(..), fakeInstalledPackageId )
import Distribution.Package import Distribution.Package
( PackageIdentifier(..), PackageName(..), Package(..), packageName ( PackageIdentifier(..), PackageName(..), Package(..), packageName
, PackageFixedDeps(..), Dependency(..) ) , PackageFixedDeps(..), Dependency(..), InstalledPackageId
, PackageInstalled(..) )
import Distribution.Version import Distribution.Version
( Version, withinRange ) ( Version, withinRange )
import Distribution.PackageDescription import Distribution.PackageDescription
...@@ -62,9 +63,9 @@ import Distribution.Client.PackageUtils ...@@ -62,9 +63,9 @@ import Distribution.Client.PackageUtils
( externalBuildDepends ) ( externalBuildDepends )
import Distribution.PackageDescription.Configuration import Distribution.PackageDescription.Configuration
( finalizePackageDescription ) ( finalizePackageDescription )
import Distribution.Client.PackageIndex import Distribution.Simple.PackageIndex
( PackageIndex ) ( PackageIndex, FakeMap )
import qualified Distribution.Client.PackageIndex as PackageIndex import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Text import Distribution.Text
( display ) ( display )
import Distribution.System import Distribution.System
...@@ -85,6 +86,10 @@ import qualified Data.Graph as Graph ...@@ -85,6 +86,10 @@ import qualified Data.Graph as Graph
import Data.Graph (Graph) import Data.Graph (Graph)
import Control.Exception import Control.Exception
( assert ) ( assert )
import Data.Maybe (catMaybes)
import qualified Data.Map as Map
type PlanIndex = PackageIndex PlanPackage
-- When cabal tries to install a number of packages, including all their -- When cabal tries to install a number of packages, including all their
-- dependencies it has a non-trivial problem to solve. -- dependencies it has a non-trivial problem to solve.
...@@ -150,31 +155,57 @@ instance PackageFixedDeps PlanPackage where ...@@ -150,31 +155,57 @@ instance PackageFixedDeps PlanPackage where
depends (Installed pkg _) = depends pkg depends (Installed pkg _) = depends pkg
depends (Failed pkg _) = depends pkg depends (Failed pkg _) = depends pkg
instance PackageInstalled PlanPackage where
installedPackageId (PreExisting pkg) = installedPackageId pkg
installedPackageId (Configured pkg) = installedPackageId pkg
installedPackageId (Processing pkg) = installedPackageId pkg
-- NB: defer to the actual installed package info in this case
installedPackageId (Installed _ (BuildOk _ _ (Just ipkg))) = installedPackageId ipkg
installedPackageId (Installed pkg _) = installedPackageId pkg
installedPackageId (Failed pkg _) = installedPackageId pkg
installedDepends (PreExisting pkg) = installedDepends pkg
installedDepends (Configured pkg) = installedDepends pkg
installedDepends (Processing pkg) = installedDepends pkg
installedDepends (Installed _ (BuildOk _ _ (Just ipkg))) = installedDepends ipkg
installedDepends (Installed pkg _) = installedDepends pkg
installedDepends (Failed pkg _) = installedDepends pkg
data InstallPlan = InstallPlan { data InstallPlan = InstallPlan {
planIndex :: PackageIndex PlanPackage, planIndex :: PlanIndex,
planFakeMap :: FakeMap,
planGraph :: Graph, planGraph :: Graph,
planGraphRev :: Graph, planGraphRev :: Graph,
planPkgOf :: Graph.Vertex -> PlanPackage, planPkgOf :: Graph.Vertex -> PlanPackage,
planVertexOf :: PackageIdentifier -> Graph.Vertex, planVertexOf :: InstalledPackageId -> Graph.Vertex,
planPlatform :: Platform, planPlatform :: Platform,
planCompiler :: CompilerId planCompiler :: CompilerId
} }
invariant :: InstallPlan -> Bool invariant :: InstallPlan -> Bool
invariant plan = invariant plan =
valid (planPlatform plan) (planCompiler plan) (planIndex plan) valid (planPlatform plan) (planCompiler plan) (planFakeMap plan) (planIndex plan)
internalError :: String -> a internalError :: String -> a
internalError msg = error $ "InstallPlan: internal error: " ++ msg internalError msg = error $ "InstallPlan: internal error: " ++ msg
-- | Build an installation plan from a valid set of resolved packages. -- | Build an installation plan from a valid set of resolved packages.
-- --
new :: Platform -> CompilerId -> PackageIndex PlanPackage new :: Platform -> CompilerId -> PlanIndex
-> Either [PlanProblem] InstallPlan -> Either [PlanProblem] InstallPlan
new platform compiler index = new platform compiler index =
case problems platform compiler index of -- NB: Need to pre-initialize the fake-map with pre-existing
-- packages
let isPreExisting (PreExisting _) = True
isPreExisting _ = False
fakeMap = Map.fromList
. map (\p -> (fakeInstalledPackageId (packageId p), installedPackageId p))
. filter isPreExisting
$ PackageIndex.allPackages index in
case problems platform compiler fakeMap index of
[] -> Right InstallPlan { [] -> Right InstallPlan {
planIndex = index, planIndex = index,
planFakeMap = fakeMap,
planGraph = graph, planGraph = graph,
planGraphRev = Graph.transposeG graph, planGraphRev = Graph.transposeG graph,
planPkgOf = vertexToPkgId, planPkgOf = vertexToPkgId,
...@@ -184,6 +215,8 @@ new platform compiler index = ...@@ -184,6 +215,8 @@ new platform compiler index =
} }
where (graph, vertexToPkgId, pkgIdToVertex) = where (graph, vertexToPkgId, pkgIdToVertex) =
PackageIndex.dependencyGraph index PackageIndex.dependencyGraph index
-- NB: doesn't need to know planFakeMap because the
-- fakemap is empty at this point.
noSuchPkgId = internalError "package is not in the graph" noSuchPkgId = internalError "package is not in the graph"
probs -> Left probs probs -> Left probs
...@@ -227,11 +260,13 @@ ready plan = assert check readyPackages ...@@ -227,11 +260,13 @@ ready plan = assert check readyPackages
] ]
hasAllInstalledDeps :: ConfiguredPackage -> Maybe [Installed.InstalledPackageInfo] hasAllInstalledDeps :: ConfiguredPackage -> Maybe [Installed.InstalledPackageInfo]
hasAllInstalledDeps = mapM isInstalledDep . depends hasAllInstalledDeps = mapM isInstalledDep . installedDepends
isInstalledDep :: PackageIdentifier -> Maybe Installed.InstalledPackageInfo isInstalledDep :: InstalledPackageId -> Maybe Installed.InstalledPackageInfo
isInstalledDep pkgid = isInstalledDep pkgid =
case PackageIndex.lookupPackageId (planIndex plan) pkgid of -- NB: Need to check if the ID has been updated in planFakeMap, in which case we
-- might be dealing with an old pointer
case PackageIndex.fakeLookupInstalledPackageId (planFakeMap plan) (planIndex plan) pkgid of
Just (Configured _) -> Nothing Just (Configured _) -> Nothing
Just (Processing _) -> Nothing Just (Processing _) -> Nothing
Just (Failed _ _) -> internalError depOnFailed Just (Failed _ _) -> internalError depOnFailed
...@@ -261,15 +296,25 @@ processing pkgs plan = assert (invariant plan') plan' ...@@ -261,15 +296,25 @@ processing pkgs plan = assert (invariant plan') plan'
-- * The package must exist in the graph and be in the processing state. -- * The package must exist in the graph and be in the processing state.
-- * The package must have had no uninstalled dependent packages. -- * The package must have had no uninstalled dependent packages.
-- --
completed :: PackageIdentifier completed :: InstalledPackageId
-> BuildSuccess -> BuildSuccess
-> InstallPlan -> InstallPlan -> InstallPlan -> InstallPlan
completed pkgid buildResult plan = assert (invariant plan') plan' completed pkgid buildResult plan = assert (invariant plan') plan'
where where
plan' = plan {