Clean up graph traversal code

Cabal/Distribution/InstalledPackageInfo.hs

@@ -112,11 +112,13 @@ data InstalledPackageInfo_ m
 
 instance Binary m => Binary (InstalledPackageInfo_ m)
 
-instance Package.Package          (InstalledPackageInfo_ str) where
+instance Package.Package (InstalledPackageInfo_ str) where
    packageId = sourcePackageId
 
-instance Package.PackageInstalled (InstalledPackageInfo_ str) where
+instance Package.HasInstalledPackageId (InstalledPackageInfo_ str) where
    installedPackageId = installedPackageId
+
+instance Package.PackageInstalled (InstalledPackageInfo_ str) where
    installedDepends = depends
 
 type InstalledPackageInfo = InstalledPackageInfo_ ModuleName

Cabal/Distribution/Package.hs

@@ -38,7 +38,7 @@ module Distribution.Package (
 
         -- * Package classes
         Package(..), packageName, packageVersion,
-        PackageFixedDeps(..),
+        HasInstalledPackageId(..),
         PackageInstalled(..),
   ) where
 
@@ -360,22 +360,15 @@ packageVersion  = pkgVersion . packageId
 instance Package PackageIdentifier where
   packageId = id
 
--- | Subclass of packages that have specific versioned dependencies.
---
--- So for example a not-yet-configured package has dependencies on version
--- ranges, not specific versions. A configured or an already installed package
--- depends on exact versions. Some operations or data structures (like
---  dependency graphs) only make sense on this subclass of package types.
---
-class Package pkg => PackageFixedDeps pkg where
-  depends :: pkg -> [PackageIdentifier]
+-- | Packages that have an installed package ID
+class Package pkg => HasInstalledPackageId pkg where
+  installedPackageId :: pkg -> InstalledPackageId
 
 -- | Class of installed packages.
 --
 -- The primary data type which is an instance of this package is
 -- 'InstalledPackageInfo', but when we are doing install plans in Cabal install
 -- we may have other, installed package-like things which contain more metadata.
 -- Installed packages have exact dependencies 'installedDepends'.
-class Package pkg => PackageInstalled pkg where
-  installedPackageId :: pkg -> InstalledPackageId
+class HasInstalledPackageId pkg => PackageInstalled pkg where
   installedDepends :: pkg -> [InstalledPackageId]

Cabal/Distribution/Simple/GHC/IPI641.hs

@@ -14,7 +14,7 @@ module Distribution.Simple.GHC.IPI641 (
   ) where
 
 import qualified Distribution.InstalledPackageInfo as Current
-import qualified Distribution.Package as Current hiding (depends, installedPackageId)
+import qualified Distribution.Package as Current hiding (installedPackageId)
 import Distribution.Text (display)
 
 import Distribution.Simple.GHC.IPI642

Cabal/Distribution/Simple/GHC/IPI642.hs

@@ -19,7 +19,7 @@ module Distribution.Simple.GHC.IPI642 (
   ) where
 
 import qualified Distribution.InstalledPackageInfo as Current
-import qualified Distribution.Package as Current hiding (depends, installedPackageId)
+import qualified Distribution.Package as Current hiding (installedPackageId)
 import qualified Distribution.License as Current
 
 import Distribution.Version (Version)

cabal-install/Distribution/Client/BuildReports/Storage.hs

@@ -135,7 +135,7 @@ fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
 
   InstallPlan.Failed (ConfiguredPackage srcPkg flags _ deps) result
     -> Just $ ( BuildReport.new os arch comp
-                                (packageId srcPkg) flags deps
+                                (packageId srcPkg) flags (map confSrcId deps)
                                 (Left result)
               , extractRepo srcPkg )
 

cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs

@@ -25,16 +25,27 @@ convCP iidx sidx (CP qpi fa es ds) =
   case convPI qpi of
     Left  pi -> PreExisting $ InstalledPackage
                   (fromJust $ SI.lookupInstalledPackageId iidx pi)
-                  (map convPI' ds)
+                  (map confSrcId ds')
     Right pi -> Configured $ ConfiguredPackage
                   (fromJust $ CI.lookupPackageId sidx pi)
                   fa
                   es
-                  (map convPI' ds)
+                  ds'
+  where
+    ds' :: [ConfiguredId]
+    ds' = map convConfId ds
 
 convPI :: PI QPN -> Either InstalledPackageId PackageId
 convPI (PI _ (I _ (Inst pi))) = Left pi
-convPI qpi                    = Right $ convPI' qpi
+convPI qpi                    = Right $ confSrcId $ convConfId qpi
 
-convPI' :: PI QPN -> PackageId
-convPI' (PI (Q _ pn) (I v _))  = PackageIdentifier pn v
+convConfId :: PI QPN -> ConfiguredId
+convConfId (PI (Q _ pn) (I v loc)) = ConfiguredId {
+      confSrcId  = sourceId
+    , confInstId = installedId
+    }
+  where
+    sourceId    = PackageIdentifier pn v
+    installedId = case loc of
+                    Inst pi    -> pi
+                    _otherwise -> fakeInstalledPackageId sourceId

cabal-install/Distribution/Client/Dependency/TopDown.hs

@@ -26,18 +26,19 @@ import Distribution.Client.InstallPlan
          ( PlanPackage(..) )
 import Distribution.Client.Types
          ( SourcePackage(..), ConfiguredPackage(..), InstalledPackage(..)
-         , enableStanzas )
+         , enableStanzas, ConfiguredId(..), fakeInstalledPackageId )
 import Distribution.Client.Dependency.Types
          ( DependencyResolver, PackageConstraint(..)
          , PackagePreferences(..), InstalledPreference(..)
          , Progress(..), foldProgress )
 
 import qualified Distribution.Client.PackageIndex as PackageIndex
-import Distribution.Client.PackageIndex (PackageIndex)
+import Distribution.Client.PackageIndex
+         ( PackageIndex )
 import Distribution.Package
          ( PackageName(..), PackageId, Package(..), packageVersion, packageName
          , Dependency(Dependency), thisPackageVersion
-         , simplifyDependency, PackageFixedDeps(depends) )
+         , simplifyDependency )
 import Distribution.PackageDescription
          ( PackageDescription(buildDepends) )
 import Distribution.Client.PackageUtils
@@ -423,7 +424,7 @@ annotateInstalledPackages dfsNumber installed = PackageIndex.fromList
     transitiveDepends :: InstalledPackage -> [PackageId]
     transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph
                       . fromJust . toVertex . packageId
-    (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed
+    (graph, toPkg, toVertex) = dependencyGraph installed
 
 
 -- | Annotate each available packages with its topological sort number and any
@@ -481,7 +482,7 @@ topologicalSortNumbering installedPkgIndex sourcePkgIndex =
          | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installedPkgIndex
          , let deps = [ packageName dep
                       | pkg' <- pkgs
-                      , dep  <- depends pkg' ] ]
+                      , dep  <- sourceDeps pkg' ] ]
       ++ [ ((), packageName pkg, nub deps)
          | pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex
          , let deps = [ depName
@@ -519,7 +520,7 @@ selectNeededSubset installedPkgIndex sourcePkgIndex = select mempty mempty
                         filter notAlreadyIncluded
                       $ [ packageName dep
                         | pkg <- moreInstalled
-                        , dep <- depends pkg ]
+                        , dep <- sourceDeps pkg ]
                      ++ [ name
                         | SourcePackage _ pkg _ _ <- moreSource
                         , Dependency name _ <-
@@ -561,7 +562,38 @@ finaliseSelectedPackages pref selected constraints =
     finaliseSource mipkg (SemiConfiguredPackage pkg flags stanzas deps) =
       InstallPlan.Configured (ConfiguredPackage pkg flags stanzas deps')
       where
-        deps' = map (packageId . pickRemaining mipkg) deps
+        deps' = map (confId . pickRemaining mipkg) deps
+
+    -- InstalledOrSource indicates that we either have a source package
+    -- available, or an installed one, or both. In the case that we have both
+    -- available, we don't yet know if we can pick the installed one (the
+    -- dependencies may not match up, for instance); this is verified in
+    -- `improvePlan`.
+    --
+    -- This means that at this point we cannot construct a valid installed
+    -- package ID yet for the dependencies. We therefore have two options:
+    --
+    -- * We could leave the installed package ID undefined here, and have a
+    --   separate pass over the output of the top-down solver, fixing all
+    --   dependencies so that if we depend on an already installed package we
+    --   use the proper installed package ID.
+    --
+    -- * We can _always_ use fake installed IDs, irrespective of whether we the
+    --   dependency is on an already installed package or not. This is okay
+    --   because (i) the top-down solver does not (and never will) support
+    --   multiple package instances, and (ii) we initialize the FakeMap with
+    --   fake IDs for already installed packages.
+    --
+    -- For now we use the second option; if however we change the implementation
+    -- of these fake IDs so that we do away with the FakeMap and update a
+    -- package reverse dependencies as we execute the install plan and discover
+    -- real package IDs, then this is no longer possible and we have to
+    -- implement the first option (see also Note [FakeMap] in Cabal).
+    confId :: InstalledOrSource InstalledPackageEx UnconfiguredPackage -> ConfiguredId
+    confId pkg = ConfiguredId {
+        confSrcId  = packageId pkg
+      , confInstId = fakeInstalledPackageId (packageId pkg)
+      }
 
     pickRemaining mipkg dep@(Dependency _name versionRange) =
           case PackageIndex.lookupDependency remainingChoices dep of
@@ -579,7 +611,7 @@ finaliseSelectedPackages pref selected constraints =
         -- silly things like deciding to rebuild haskell98 against base 3.
         isCurrent = case mipkg :: Maybe InstalledPackageEx of
           Nothing   -> \_ -> False
-          Just ipkg -> \p -> packageId p `elem` depends ipkg
+          Just ipkg -> \p -> packageId p `elem` sourceDeps ipkg
         -- If there is no upper bound on the version range then we apply a
         -- preferred version according to the hackage or user's suggested
         -- version constraints. TODO: distinguish hacks from prefs
@@ -627,7 +659,7 @@ improvePlan installed constraints0 selected0 =
     improvePkg selected constraints pkgid = do
       Configured pkg  <- PackageIndex.lookupPackageId selected  pkgid
       ipkg            <- PackageIndex.lookupPackageId installed pkgid
-      guard $ all (isInstalled selected) (depends pkg)
+      guard $ all (isInstalled selected) (sourceDeps pkg)
       tryInstalled selected constraints [ipkg]
 
     isInstalled selected pkgid =
@@ -640,12 +672,12 @@ improvePlan installed constraints0 selected0 =
                  -> Maybe (PackageIndex PlanPackage, Constraints)
     tryInstalled selected constraints [] = Just (selected, constraints)
     tryInstalled selected constraints (pkg:pkgs) =
-      case constraintsOk (packageId pkg) (depends pkg) constraints of
+      case constraintsOk (packageId pkg) (sourceDeps pkg) constraints of
         Nothing           -> Nothing
         Just constraints' -> tryInstalled selected' constraints' pkgs'
           where
             selected' = PackageIndex.insert (PreExisting pkg) selected
-            pkgs'      = catMaybes (map notSelected (depends pkg)) ++ pkgs
+            pkgs'      = catMaybes (map notSelected (sourceDeps pkg)) ++ pkgs
             notSelected pkgid =
               case (PackageIndex.lookupPackageId installed pkgid
                    ,PackageIndex.lookupPackageId selected  pkgid) of
@@ -660,13 +692,12 @@ improvePlan installed constraints0 selected0 =
       where
         dep = thisPackageVersion pkgid'
 
-    reverseTopologicalOrder :: PackageFixedDeps pkg
-                            => PackageIndex pkg -> [PackageId]
+    reverseTopologicalOrder :: PackageIndex PlanPackage -> [PackageId]
     reverseTopologicalOrder index = map (packageId . toPkg)
                                   . Graph.topSort
                                   . Graph.transposeG
                                   $ graph
-      where (graph, toPkg, _) = PackageIndex.dependencyGraph index
+      where (graph, toPkg, _) = dependencyGraph index
 
 -- ------------------------------------------------------------
 -- * Adding and recording constraints
@@ -944,3 +975,49 @@ listOf disp [x0] = disp x0
 listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs
   where go x []       = " and " ++ disp x
         go x (x':xs') = ", " ++ disp x ++ go x' xs'
+
+-- ------------------------------------------------------------
+-- * Construct a dependency graph
+-- ------------------------------------------------------------
+
+-- | Builds a graph of the package dependencies.
+--
+-- Dependencies on other packages that are not in the index are discarded.
+-- You can check if there are any such dependencies with 'brokenPackages'.
+--
+-- The top-down solver gets its own implementation, because both
+-- `dependencyGraph` in `Distribution.Client.PlanIndex` (in cabal-install) and
+-- `dependencyGraph` in `Distribution.Simple.PackageIndex` (in Cabal) both work
+-- with `PackageIndex` from `Cabal` (that is, a package index indexed by
+-- installed package IDs rather than package names).
+--
+-- Ideally we would switch the top-down solver over to use that too, so that
+-- this duplication could be avoided, but that's a bit of work and the top-down
+-- solver is legacy code anyway.
+--
+-- (NOTE: This is called at two types: InstalledPackage and PlanPackage.)
+dependencyGraph :: PackageSourceDeps pkg
+                => PackageIndex pkg
+                -> (Graph.Graph,
+                    Graph.Vertex -> pkg,
+                    PackageId -> Maybe Graph.Vertex)
+dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex)
+  where
+    graph = Array.listArray bounds $
+            map (catMaybes . map pkgIdToVertex . sourceDeps) pkgs
+    vertexToPkg vertex = pkgTable Array.! vertex
+    pkgIdToVertex = binarySearch 0 topBound
+
+    pkgTable   = Array.listArray bounds pkgs
+    pkgIdTable = Array.listArray bounds (map packageId pkgs)
+    pkgs = sortBy (comparing packageId) (PackageIndex.allPackages index)
+    topBound = length pkgs - 1
+    bounds = (0, topBound)
+
+    binarySearch a b key
+      | a > b     = Nothing
+      | otherwise = case compare key (pkgIdTable Array.! mid) of
+          LT -> binarySearch a (mid-1) key
+          EQ -> Just mid
+          GT -> binarySearch (mid+1) b key
+      where mid = (a + b) `div` 2

cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs

@@ -26,11 +26,12 @@ module Distribution.Client.Dependency.TopDown.Constraints (
 
 import Distribution.Client.Dependency.TopDown.Types
 import qualified Distribution.Client.PackageIndex as PackageIndex
-import Distribution.Client.PackageIndex (PackageIndex)
+import Distribution.Client.PackageIndex
+        ( PackageIndex )
 import Distribution.Package
          ( PackageName, PackageId, PackageIdentifier(..)
          , Package(packageId), packageName, packageVersion
-         , Dependency, PackageFixedDeps(depends) )
+         , Dependency )
 import Distribution.Version
          ( Version )
 import Distribution.Client.Utils
@@ -224,14 +225,12 @@ transitionsTo constraints @(Constraints _ available  excluded  _ _)
       SourceOnly           b -> SourceOnly    (g b)
       InstalledAndSource a b -> InstalledAndSource (f a) (g b)
 
-
 -- | We construct 'Constraints' with an initial 'PackageIndex' of all the
 -- packages available.
 --
-empty :: (PackageFixedDeps installed, Package source)
-      => PackageIndex installed
-      -> PackageIndex source
-      -> Constraints installed source reason
+empty :: PackageIndex InstalledPackageEx
+      -> PackageIndex UnconfiguredPackage
+      -> Constraints InstalledPackageEx UnconfiguredPackage reason
 empty installed source =
     Constraints targets pkgs excluded pairs pkgs
   where
@@ -253,8 +252,8 @@ empty installed source =
       , let name   = packageName pkg1
             pkgid1 = packageId pkg1
             pkgid2 = packageId pkg2
-      ,    any ((pkgid1==) . packageId) (depends pkg2)
-        || any ((pkgid2==) . packageId) (depends pkg1) ]
+      ,    any ((pkgid1==) . packageId) (sourceDeps pkg2)
+        || any ((pkgid2==) . packageId) (sourceDeps pkg1) ]
 
 
 -- | The package targets.