Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
8cf73788
Commit
8cf73788
authored
Nov 03, 2014
by
Mikhail Glushenkov
Browse files
Merge pull request #2142 from ezyang/ezyang-edge
Switch InstallPlan over to using IPID-indexed PackageIndex.
parents
7207e68f
4856af6f
Changes
6
Hide whitespace changes
Inline
Side-by-side
Cabal/Distribution/Simple/PackageIndex.hs
View file @
8cf73788
...
...
@@ -16,6 +16,7 @@ module Distribution.Simple.PackageIndex (
-- * Package index data type
InstalledPackageIndex
,
PackageIndex
,
FakeMap
,
-- * Creating an index
fromList
,
...
...
@@ -59,6 +60,15 @@ module Distribution.Simple.PackageIndex (
dependencyCycles
,
dependencyGraph
,
moduleNameIndex
,
-- ** Variants of special queries supporting fake map
fakeLookupInstalledPackageId
,
brokenPackages'
,
dependencyClosure'
,
reverseDependencyClosure'
,
dependencyInconsistencies'
,
dependencyCycles'
,
dependencyGraph'
,
)
where
import
Control.Exception
(
assert
)
...
...
@@ -91,6 +101,40 @@ import Distribution.Version
(
Version
,
withinRange
)
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.
-- These packages generally should have an instance of 'PackageInstalled'
--
...
...
@@ -203,7 +247,7 @@ fromList pkgs = mkPackageIndex pids pnames
--
merge
::
PackageInstalled
a
=>
PackageIndex
a
->
PackageIndex
a
->
PackageIndex
a
merge
(
PackageIndex
pids1
pnames1
)
(
PackageIndex
pids2
pnames2
)
=
mkPackageIndex
(
Map
.
union
pids1
pids2
)
mkPackageIndex
(
Map
.
union
With
(
\
_
y
->
y
)
pids1
pids2
)
(
Map
.
unionWith
(
Map
.
unionWith
mergeBuckets
)
pnames1
pnames2
)
where
-- Packages in the second list mask those in the first, however preferred
...
...
@@ -444,10 +488,14 @@ searchByNameSubstring (PackageIndex _ pnames) searchterm =
-- other, directly or indirectly.
--
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
]
where
adjacencyList
=
[
(
pkg
,
installedPackageId
pkg
,
i
nstalledDepends
pkg
)
adjacencyList
=
[
(
pkg
,
installedPackageId
pkg
,
fakeI
nstalledDepends
fakeMap
pkg
)
|
pkg
<-
allPackages
index
]
...
...
@@ -456,13 +504,20 @@ dependencyCycles index =
-- Returns such packages along with the dependencies that they're missing.
--
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
<-
allPackages
index
,
let
missing
=
[
pkg'
|
pkg'
<-
installedDepends
pkg
,
isNothing
(
l
ookupInstalledPackageId
index
pkg'
)
]
,
isNothing
(
fakeL
ookupInstalledPackageId
fakeMap
index
pkg'
)
]
,
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.
--
...
...
@@ -476,14 +531,22 @@ dependencyClosure :: PackageInstalled a => PackageIndex a
->
[
InstalledPackageId
]
->
Either
(
PackageIndex
a
)
[(
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
,
_
)
->
Right
(
brokenPackages
completed
)
where
closure
completed
failed
[]
=
(
completed
,
failed
)
closure
completed
failed
(
pkgid
:
pkgids
)
=
case
l
ookupInstalledPackageId
index
pkgid
of
closure
completed
failed
(
pkgid
:
pkgids
)
=
case
fakeL
ookupInstalledPackageId
fakeMap
index
pkgid
of
Nothing
->
closure
completed
(
pkgid
:
failed
)
pkgids
Just
pkg
->
case
l
ookupInstalledPackageId
completed
(
installedPackageId
pkg
)
of
Just
pkg
->
case
fakeL
ookupInstalledPackageId
fakeMap
completed
(
installedPackageId
pkg
)
of
Just
_
->
closure
completed
failed
pkgids
Nothing
->
closure
completed'
failed
pkgids'
where
completed'
=
insert
pkg
completed
...
...
@@ -496,14 +559,21 @@ dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of
reverseDependencyClosure
::
PackageInstalled
a
=>
PackageIndex
a
->
[
InstalledPackageId
]
->
[
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
.
concatMap
Tree
.
flatten
.
Graph
.
dfs
reverseDepGraph
.
map
(
fromMaybe
noSuchPkgId
.
pkgIdToVertex
)
where
(
depGraph
,
vertexToPkg
,
pkgIdToVertex
)
=
dependencyGraph
index
(
depGraph
,
vertexToPkg
,
pkgIdToVertex
)
=
dependencyGraph
'
fakeMap
index
reverseDepGraph
=
Graph
.
transposeG
depGraph
noSuchPkgId
=
error
"reverseDependencyClosure: package is not in the graph"
...
...
@@ -529,7 +599,15 @@ dependencyGraph :: PackageInstalled a => PackageIndex a
->
(
Graph
.
Graph
,
Graph
.
Vertex
->
a
,
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
graph
=
Array
.
listArray
bounds
[
[
v
|
Just
v
<-
map
id_to_vertex
(
installedDepends
pkg
)
]
...
...
@@ -538,7 +616,7 @@ dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex)
pkgs
=
sortBy
(
comparing
packageId
)
(
allPackages
index
)
vertices
=
zip
(
map
installedPackageId
pkgs
)
[
0
..
]
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
...
...
@@ -558,7 +636,12 @@ dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex)
--
dependencyInconsistencies
::
PackageInstalled
a
=>
PackageIndex
a
->
[(
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
,
ipid_map
)
<-
Map
.
toList
inverseIndex
,
let
uses
=
Map
.
elems
ipid_map
...
...
@@ -572,18 +655,23 @@ dependencyInconsistencies index =
[
(
packageName
dep
,
Map
.
fromList
[(
ipid
,(
dep
,[
packageId
pkg
]))])
|
pkg
<-
allPackages
index
,
ipid
<-
i
nstalledDepends
pkg
,
Just
dep
<-
[
l
ookupInstalledPackageId
index
ipid
]
,
ipid
<-
fakeI
nstalledDepends
fakeMap
pkg
,
Just
dep
<-
[
fakeL
ookupInstalledPackageId
fakeMap
index
ipid
]
]
reallyIsInconsistent
::
PackageInstalled
a
=>
[
a
]
->
Bool
reallyIsInconsistent
[]
=
False
reallyIsInconsistent
[
_p
]
=
False
reallyIsInconsistent
[
p1
,
p2
]
=
installedPackageId
p1
`
notElem
`
installedDepends
p2
&&
installedPackageId
p2
`
notElem
`
installedDepends
p1
let
pid1
=
installedPackageId
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
-- | 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
-- turns it into a map from module names to their source packages. It's used to
...
...
cabal-install/Distribution/Client/Dependency.hs
View file @
8cf73788
...
...
@@ -554,12 +554,15 @@ mkInstallPlan :: Platform
->
CompilerId
->
[
InstallPlan
.
PlanPackage
]
->
InstallPlan
mkInstallPlan
platform
comp
pkgIndex
=
case
InstallPlan
.
new
platform
comp
(
PackageIndex
.
fromList
pkgIndex
)
of
let
index
=
InstalledPackageIndex
.
fromList
pkgIndex
in
case
InstallPlan
.
new
platform
comp
index
of
Right
plan
->
plan
Left
problems
->
error
$
unlines
$
"internal error: could not construct a valid install plan."
:
"The proposed (invalid) plan contained the following problems:"
:
map
InstallPlan
.
showPlanProblem
problems
++
"Proposed plan:"
:
[
InstallPlan
.
showPlanIndex
index
]
-- | Give an interpretation to the global 'PackagesPreference' as
...
...
cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
View file @
8cf73788
...
...
@@ -17,7 +17,7 @@ mkPlan :: Platform -> CompilerId ->
SI
.
InstalledPackageIndex
->
CI
.
PackageIndex
SourcePackage
->
[
CP
QPN
]
->
Either
[
PlanProblem
]
InstallPlan
mkPlan
plat
comp
iidx
sidx
cps
=
new
plat
comp
(
C
I
.
fromList
(
map
(
convCP
iidx
sidx
)
cps
))
new
plat
comp
(
S
I
.
fromList
(
map
(
convCP
iidx
sidx
)
cps
))
convCP
::
SI
.
InstalledPackageIndex
->
CI
.
PackageIndex
SourcePackage
->
CP
QPN
->
PlanPackage
...
...
cabal-install/Distribution/Client/Install.hs
View file @
8cf73788
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Install
...
...
@@ -126,7 +127,7 @@ import Distribution.Simple.InstallDirs as InstallDirs
import
Distribution.Package
(
PackageIdentifier
(
..
),
PackageId
,
packageName
,
packageVersion
,
Package
(
..
),
PackageFixedDeps
(
..
),
PackageKey
,
Dependency
(
..
),
thisPackageVersion
,
InstalledPackageId
)
,
Dependency
(
..
),
thisPackageVersion
,
InstalledPackageId
,
installedPackageId
)
import
qualified
Distribution.PackageDescription
as
PackageDescription
import
Distribution.PackageDescription
(
PackageDescription
,
GenericPackageDescription
(
..
),
Flag
(
..
)
...
...
@@ -517,15 +518,18 @@ linearizeInstallPlan comp installedPkgIndex plan =
[]
->
Nothing
(
pkg
:
_
)
->
Just
((
pkg
,
status
),
plan''
)
where
pkgid
=
p
ackageId
pkg
pkgid
=
installedP
ackageId
pkg
status
=
packageStatus
comp
installedPkgIndex
pkg
plan''
=
InstallPlan
.
completed
pkgid
(
BuildOk
DocsNotTried
TestsNotTried
(
Just
$
Installed
.
emptyInstalledPackageInfo
{
Installed
.
sourcePackageId
=
pkgid
}))
{
Installed
.
sourcePackageId
=
packageId
pkg
,
Installed
.
installedPackageId
=
pkgid
}))
(
InstallPlan
.
processing
[
pkg
]
plan'
)
--FIXME: This is a bit of a hack,
-- pretending that each package is installed
-- It's doubly a hack because the installed package ID
-- didn't get updated...
data
PackageStatus
=
NewPackage
|
NewVersion
[
Version
]
...
...
@@ -1126,10 +1130,10 @@ executeInstallPlan verbosity comp jobCtl useLogFile plan0 installPkg =
updatePlan
::
PackageIdentifier
->
BuildResult
->
InstallPlan
->
InstallPlan
updatePlan
pkgid
(
Right
buildSuccess
)
=
InstallPlan
.
completed
pkgid
buildSuccess
InstallPlan
.
completed
(
Source
.
fakeInstalledPackageId
pkgid
)
buildSuccess
updatePlan
pkgid
(
Left
buildFailure
)
=
InstallPlan
.
failed
pkgid
buildFailure
depsFailure
InstallPlan
.
failed
(
Source
.
fakeInstalledPackageId
pkgid
)
buildFailure
depsFailure
where
depsFailure
=
DependentFailed
pkgid
-- So this first pkgid failed for whatever reason (buildFailure).
...
...
cabal-install/Distribution/Client/InstallPlan.hs
View file @
8cf73788
...
...
@@ -24,6 +24,8 @@ module Distribution.Client.InstallPlan (
completed
,
failed
,
remove
,
showPlanIndex
,
showInstallPlan
,
-- ** Query functions
planPlatform
,
...
...
@@ -49,10 +51,11 @@ import Distribution.Client.Types
(
SourcePackage
(
packageDescription
),
ConfiguredPackage
(
..
)
,
ReadyPackage
(
..
),
readyPackageToConfiguredPackage
,
InstalledPackage
,
BuildFailure
,
BuildSuccess
(
..
),
enableStanzas
,
InstalledPackage
(
..
)
)
,
InstalledPackage
(
..
)
,
fakeInstalledPackageId
)
import
Distribution.Package
(
PackageIdentifier
(
..
),
PackageName
(
..
),
Package
(
..
),
packageName
,
PackageFixedDeps
(
..
),
Dependency
(
..
)
)
,
PackageFixedDeps
(
..
),
Dependency
(
..
),
InstalledPackageId
,
PackageInstalled
(
..
)
)
import
Distribution.Version
(
Version
,
withinRange
)
import
Distribution.PackageDescription
...
...
@@ -62,9 +65,9 @@ import Distribution.Client.PackageUtils
(
externalBuildDepends
)
import
Distribution.PackageDescription.Configuration
(
finalizePackageDescription
)
import
Distribution.
Client
.PackageIndex
(
PackageIndex
)
import
qualified
Distribution.
Client
.PackageIndex
as
PackageIndex
import
Distribution.
Simple
.PackageIndex
(
PackageIndex
,
FakeMap
)
import
qualified
Distribution.
Simple
.PackageIndex
as
PackageIndex
import
Distribution.Text
(
display
)
import
Distribution.System
...
...
@@ -85,6 +88,10 @@ import qualified Data.Graph as Graph
import
Data.Graph
(
Graph
)
import
Control.Exception
(
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
-- dependencies it has a non-trivial problem to solve.
...
...
@@ -150,31 +157,78 @@ instance PackageFixedDeps PlanPackage where
depends
(
Installed
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
{
planIndex
::
PackageIndex
PlanPackage
,
planIndex
::
PlanIndex
,
planFakeMap
::
FakeMap
,
planGraph
::
Graph
,
planGraphRev
::
Graph
,
planPkgOf
::
Graph
.
Vertex
->
PlanPackage
,
planVertexOf
::
PackageId
entifier
->
Graph
.
Vertex
,
planVertexOf
::
Installed
PackageId
->
Graph
.
Vertex
,
planPlatform
::
Platform
,
planCompiler
::
CompilerId
}
invariant
::
InstallPlan
->
Bool
invariant
plan
=
valid
(
planPlatform
plan
)
(
planCompiler
plan
)
(
planIndex
plan
)
valid
(
planPlatform
plan
)
(
planCompiler
plan
)
(
planFakeMap
plan
)
(
planIndex
plan
)
internalError
::
String
->
a
internalError
msg
=
error
$
"InstallPlan: internal error: "
++
msg
showPlanIndex
::
PlanIndex
->
String
showPlanIndex
index
=
intercalate
"
\n
"
(
map
showPlanPackage
(
PackageIndex
.
allPackages
index
))
where
showPlanPackage
p
=
showPlanPackageTag
p
++
" "
++
display
(
packageId
p
)
++
" ("
++
display
(
installedPackageId
p
)
++
")"
showInstallPlan
::
InstallPlan
->
String
showInstallPlan
plan
=
showPlanIndex
(
planIndex
plan
)
++
"
\n
"
++
"fake map:
\n
"
++
intercalate
"
\n
"
(
map
showKV
(
Map
.
toList
(
planFakeMap
plan
)))
where
showKV
(
k
,
v
)
=
display
k
++
" -> "
++
display
v
showPlanPackageTag
::
PlanPackage
->
String
showPlanPackageTag
(
PreExisting
_
)
=
"PreExisting"
showPlanPackageTag
(
Configured
_
)
=
"Configured"
showPlanPackageTag
(
Processing
_
)
=
"Processing"
showPlanPackageTag
(
Installed
_
_
)
=
"Installed"
showPlanPackageTag
(
Failed
_
_
)
=
"Failed"
-- | Build an installation plan from a valid set of resolved packages.
--
new
::
Platform
->
CompilerId
->
P
ackageIndex
PlanPackage
new
::
Platform
->
CompilerId
->
P
lanIndex
->
Either
[
PlanProblem
]
InstallPlan
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
{
planIndex
=
index
,
planFakeMap
=
fakeMap
,
planGraph
=
graph
,
planGraphRev
=
Graph
.
transposeG
graph
,
planPkgOf
=
vertexToPkgId
,
...
...
@@ -184,6 +238,8 @@ new platform compiler index =
}
where
(
graph
,
vertexToPkgId
,
pkgIdToVertex
)
=
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"
probs
->
Left
probs
...
...
@@ -227,11 +283,13 @@ ready plan = assert check readyPackages
]
hasAllInstalledDeps
::
ConfiguredPackage
->
Maybe
[
Installed
.
InstalledPackageInfo
]
hasAllInstalledDeps
=
mapM
isInstalledDep
.
d
epends
hasAllInstalledDeps
=
mapM
isInstalledDep
.
installedD
epends
isInstalledDep
::
PackageId
entifier
->
Maybe
Installed
.
InstalledPackageInfo
isInstalledDep
::
Installed
PackageId
->
Maybe
Installed
.
InstalledPackageInfo
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
(
Processing
_
)
->
Nothing
Just
(
Failed
_
_
)
->
internalError
depOnFailed
...
...
@@ -261,15 +319,25 @@ processing pkgs plan = assert (invariant plan') plan'
-- * The package must exist in the graph and be in the processing state.
-- * The package must have had no uninstalled dependent packages.
--
completed
::
PackageId
entifier
completed
::
Installed
PackageId
->
BuildSuccess
->
InstallPlan
->
InstallPlan
completed
pkgid
buildResult
plan
=
assert
(
invariant
plan'
)
plan'
where
plan'
=
plan
{
planIndex
=
PackageIndex
.
insert
installed
(
planIndex
plan
)
-- NB: installation can change the IPID, so better
-- record it in the fake mapping...
planFakeMap
=
insert_fake_mapping
buildResult
$
planFakeMap
plan
,
planIndex
=
PackageIndex
.
insert
installed
.
PackageIndex
.
deleteInstalledPackageId
pkgid
$
planIndex
plan
}
-- ...but be sure to use the *old* IPID for the lookup for the
-- preexisting record
installed
=
Installed
(
lookupProcessingPackage
plan
pkgid
)
buildResult
insert_fake_mapping
(
BuildOk
_
_
(
Just
ipi
))
=
Map
.
insert
pkgid
(
installedPackageId
ipi
)
insert_fake_mapping
_
=
id
-- | Marks a package in the graph as having failed. It also marks all the
-- packages that depended on it as having failed.
...
...
@@ -277,13 +345,14 @@ completed pkgid buildResult plan = assert (invariant plan') plan'
-- * The package must exist in the graph and be in the processing
-- state.
--
failed
::
PackageId
entifier
-- ^ The id of the package that failed to install
failed
::
Installed
PackageId
-- ^ The id of the package that failed to install
->
BuildFailure
-- ^ The build result to use for the failed package
->
BuildFailure
-- ^ The build result to use for its dependencies
->
InstallPlan
->
InstallPlan
failed
pkgid
buildResult
buildResult'
plan
=
assert
(
invariant
plan'
)
plan'
where
-- NB: failures don't update IPIDs
plan'
=
plan
{
planIndex
=
PackageIndex
.
merge
(
planIndex
plan
)
failures
}
...
...
@@ -297,7 +366,7 @@ failed pkgid buildResult buildResult' plan = assert (invariant plan') plan'
-- | Lookup the reachable packages in the reverse dependency graph.
--
packagesThatDependOn
::
InstallPlan
->
PackageId
entifier
->
[
PlanPackage
]
->
Installed
PackageId
->
[
PlanPackage
]
packagesThatDependOn
plan
=
map
(
planPkgOf
plan
)
.
tail
.
Graph
.
reachable
(
planGraphRev
plan
)
...
...
@@ -306,9 +375,11 @@ packagesThatDependOn plan = map (planPkgOf plan)
-- | Lookup a package that we expect to be in the processing state.
--
lookupProcessingPackage
::
InstallPlan
->
PackageId
entifier
->
ReadyPackage
->
Installed
PackageId
->
ReadyPackage
lookupProcessingPackage
plan
pkgid
=
case
PackageIndex
.
lookupPackageId
(
planIndex
plan
)
pkgid
of
-- NB: processing packages are guaranteed to not indirect through
-- planFakeMap
case
PackageIndex
.
lookupInstalledPackageId
(
planIndex
plan
)
pkgid
of
Just
(
Processing
pkg
)
->
pkg
_
->
internalError
$
"not in processing state or no such pkg "
++
display
pkgid
...
...
@@ -330,8 +401,8 @@ checkConfiguredPackage pkg =
--
-- * if the result is @False@ use 'problems' to get a detailed list.
--
valid
::
Platform
->
CompilerId
->
PackageIndex
PlanPackage
->
Bool
valid
platform
comp
index
=
null
(
problems
platform
comp
index
)
valid
::
Platform
->
CompilerId
->
FakeMap
->
PlanIndex
->
Bool
valid
platform
comp
fakeMap
index
=
null
(
problems
platform
comp
fakeMap
index
)
data
PlanProblem
=
PackageInvalid
ConfiguredPackage
[
PackageProblem
]
...
...
@@ -381,26 +452,26 @@ showPlanProblem (PackageStateInvalid pkg pkg') =
-- error messages. This is mainly intended for debugging purposes.
-- Use 'showPlanProblem' for a human readable explanation.
--
problems
::
Platform
->
CompilerId
->
P
ackageIndex
PlanPackage
->
[
PlanProblem
]
problems
platform
comp
index
=
problems
::
Platform
->
CompilerId
->
FakeMap
->
P
lanIndex
->
[
PlanProblem
]
problems
platform
comp
fakeMap
index
=
[
PackageInvalid
pkg
packageProblems
|
Configured
pkg
<-
PackageIndex
.
allPackages
index
,
let
packageProblems
=
configuredPackageProblems
platform
comp
pkg
,
not
(
null
packageProblems
)
]
++
[
PackageMissingDeps
pkg
missingDeps
|
(
pkg
,
missingDeps
)
<-
PackageIndex
.
brokenPackages
index
]
++
[
PackageMissingDeps
pkg
(
catMaybes
(
map
(
fmap
packageId
.
PackageIndex
.
fakeLookupInstalledPackageId
fakeMap
index
)
missingDeps
))
|
(
pkg
,
missingDeps
)
<-
PackageIndex
.
brokenPackages
'
fakeMap
index
]
++
[
PackageCycle
cycleGroup
|
cycleGroup
<-
PackageIndex
.
dependencyCycles
index
]
|
cycleGroup
<-
PackageIndex
.
dependencyCycles
'
fakeMap
index
]
++
[
PackageInconsistency
name
inconsistencies
|
(
name
,
inconsistencies
)
<-
PackageIndex
.
dependencyInconsistencies
index
]
|
(
name
,
inconsistencies
)
<-
PackageIndex
.
dependencyInconsistencies
'
fakeMap
index
]
++
[
PackageStateInvalid
pkg
pkg'
|
pkg
<-
PackageIndex
.
allPackages
index
,
Just
pkg'
<-
map
(
PackageIndex
.
lookupPackageId
index
)
(
d
epends
pkg
)
,
Just
pkg'
<-
map
(
PackageIndex
.
fakeLookupInstalledPackageId
fakeMap
index
)
(
installedD
epends
pkg
)
,
not
(
stateDependencyRelation
pkg
pkg'
)
]
-- | The graph of packages (nodes) and dependencies (edges) must be acyclic.
...
...
@@ -408,7 +479,7 @@ problems platform comp index =
-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out
-- which packages are involved in dependency cycles.
--
acyclic
::
P
ackageIndex
PlanPackage
->
Bool
acyclic
::
P
lanIndex
->
Bool
acyclic
=
null
.
PackageIndex
.
dependencyCycles
-- | An installation plan is closed if for every package in the set, all of
...
...
@@ -418,7 +489,7 @@ acyclic = null . PackageIndex.dependencyCycles
-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out
-- which packages depend on packages not in the index.
--
closed
::
P
ackageIndex
PlanPackage
->
Bool
closed
::
P
lanIndex
->
Bool
closed
=
null
.
PackageIndex
.
brokenPackages
-- | An installation plan is consistent if all dependencies that target a
...
...
@@ -437,7 +508,7 @@ closed = null . PackageIndex.brokenPackages
-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to
-- find out which packages are.
--
consistent
::
P
ackageIndex
PlanPackage
->
Bool
consistent
::
P
lanIndex
->
Bool
consistent
=
null
.
PackageIndex
.
dependencyInconsistencies
-- | The states of packages have that depend on each other must respect
...
...
cabal-install/Distribution/Client/Types.hs
View file @
8cf73788
...
...
@@ -16,7 +16,8 @@ module Distribution.Client.Types where
import
Distribution.Package
(
PackageName
,
PackageId
,
Package
(
..
),
PackageFixedDeps
(
..
)