Cabal/src/Distribution/Simple/PackageIndex.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5
   6 -----------------------------------------------------------------------------
   7
   8 -- |
   9 -- Module      :  Distribution.Simple.PackageIndex
  10 -- Copyright   :  (c) David Himmelstrup 2005,
  11 --                    Bjorn Bringert 2007,
  12 --                    Duncan Coutts 2008-2009
  13 --
  14 -- Maintainer  :  cabal-devel@haskell.org
  15 -- Portability :  portable
  16 --
  17 -- An index of packages whose primary key is 'UnitId'.  Public libraries
  18 -- are additionally indexed by 'PackageName' and 'Version'.
  19 -- Technically, these are an index of *units* (so we should eventually
  20 -- rename it to 'UnitIndex'); but in the absence of internal libraries
  21 -- or Backpack each unit is equivalent to a package.
  22 --
  23 -- While 'PackageIndex' is parametric over what it actually records,
  24 -- it is in fact only ever instantiated with a single element:
  25 -- The 'InstalledPackageIndex' (defined here) contains a graph of
  26 -- 'InstalledPackageInfo's representing the packages in a
  27 -- package database stack.  It is used in a variety of ways:
  28 --
  29 --   * The primary use to let Cabal access the same installed
  30 --     package database which is used by GHC during compilation.
  31 --     For example, this data structure is used by 'ghc-pkg'
  32 --     and 'Cabal' to do consistency checks on the database
  33 --     (are the references closed).
  34 --
  35 --   * Given a set of dependencies, we can compute the transitive
  36 --     closure of dependencies.  This is to check if the versions
  37 --     of packages are consistent, and also needed by multiple
  38 --     tools (Haddock must be explicitly told about the every
  39 --     transitive package to do cross-package linking;
  40 --     preprocessors must know about the include paths of all
  41 --     transitive dependencies.)
  42 --
  43 -- This 'PackageIndex' is NOT to be confused with
  44 -- 'Distribution.Client.PackageIndex', which indexes packages only by
  45 -- 'PackageName' (this makes it suitable for indexing source packages,
  46 -- for which we don't know 'UnitId's.)
  47 module Distribution.Simple.PackageIndex
  48   ( -- * Package index data type
  49     InstalledPackageIndex
  50   , PackageIndex
  51
  52     -- * Creating an index
  53   , fromList
  54
  55     -- * Updates
  56   , merge
  57   , insert
  58   , deleteUnitId
  59   , deleteSourcePackageId
  60   , deletePackageName
  61   --  deleteDependency,
  62
  63     -- * Queries
  64
  65     -- ** Precise lookups
  66   , lookupUnitId
  67   , lookupComponentId
  68   , lookupSourcePackageId
  69   , lookupPackageId
  70   , lookupPackageName
  71   , lookupDependency
  72   , lookupInternalDependency
  73
  74     -- ** Case-insensitive searches
  75   , searchByName
  76   , SearchResult (..)
  77   , searchByNameSubstring
  78   , searchWithPredicate
  79
  80     -- ** Bulk queries
  81   , allPackages
  82   , allPackagesByName
  83   , allPackagesBySourcePackageId
  84   , allPackagesBySourcePackageIdAndLibName
  85
  86     -- ** Special queries
  87   , brokenPackages
  88   , dependencyClosure
  89   , reverseDependencyClosure
  90   , topologicalOrder
  91   , reverseTopologicalOrder
  92   , dependencyInconsistencies
  93   , dependencyCycles
  94   , dependencyGraph
  95   , moduleNameIndex
  96   ) where
  97
  98 import qualified Data.Map.Strict as Map
  99 import Distribution.Compat.Prelude hiding (lookup)
 100 import Prelude ()
 101
 102 import Distribution.Backpack
 103 import qualified Distribution.InstalledPackageInfo as IPI
 104 import Distribution.ModuleName
 105 import Distribution.Package
 106 import Distribution.Simple.Utils
 107 import Distribution.Types.LibraryName
 108 import Distribution.Version
 109
 110 import Control.Exception (assert)
 111 import Control.Monad
 112 import Data.Array ((!))
 113 import qualified Data.Array as Array
 114 import qualified Data.Graph as Graph
 115 import Data.List as List (deleteBy, deleteFirstsBy, groupBy)
 116 import qualified Data.List.NonEmpty as NE
 117 import qualified Data.Tree as Tree
 118 import Distribution.Compat.Stack
 119
 120 import qualified Prelude (foldr1)
 121
 122 -- | The collection of information about packages from one or more 'PackageDB's.
 123 -- These packages generally should have an instance of 'PackageInstalled'
 124 --
 125 -- Packages are uniquely identified in by their 'UnitId', they can
 126 -- also be efficiently looked up by package name or by name and version.
 127 data PackageIndex a = PackageIndex
 128   { -- The primary index. Each InstalledPackageInfo record is uniquely identified
 129     -- by its UnitId.
 130     --
 131     unitIdIndex :: !(Map UnitId a)
 132   , -- This auxiliary index maps package names (case-sensitively) to all the
 133     -- versions and instances of that package. This allows us to find all
 134     -- versions satisfying a dependency.
 135     --
 136     -- It is a three-level index. The first level is the package name,
 137     -- the second is the package version and the final level is instances
 138     -- of the same package version. These are unique by UnitId
 139     -- and are kept in preference order.
 140     --
 141     -- FIXME: Clarify what "preference order" means. Check that this invariant is
 142     -- preserved. See #1463 for discussion.
 143     packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a]))
 144   }
 145   deriving (Eq, Generic, Show, Read, Typeable)
 146
 147 instance Binary a => Binary (PackageIndex a)
 148 instance Structured a => Structured (PackageIndex a)
 149
 150 -- | The default package index which contains 'InstalledPackageInfo'.  Normally
 151 -- use this.
 152 type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo
 153
 154 instance Monoid (PackageIndex IPI.InstalledPackageInfo) where
 155   mempty = PackageIndex Map.empty Map.empty
 156   mappend = (<>)
 157
 158   -- save one mappend with empty in the common case:
 159   mconcat [] = mempty
 160   mconcat xs = Prelude.foldr1 mappend xs
 161
 162 instance Semigroup (PackageIndex IPI.InstalledPackageInfo) where
 163   (<>) = merge
 164
 165 {-# NOINLINE invariant #-}
 166 invariant :: WithCallStack (InstalledPackageIndex -> Bool)
 167 invariant (PackageIndex pids pnames) =
 168   -- trace (show pids' ++ "\n" ++ show pnames') $
 169   pids' == pnames'
 170   where
 171     pids' = map installedUnitId (Map.elems pids)
 172     pnames' =
 173       sort
 174         [ assert pinstOk (installedUnitId pinst)
 175         | ((pname, plib), pvers) <- Map.toList pnames
 176         , let pversOk = not (Map.null pvers)
 177         , (pver, pinsts) <- assert pversOk $ Map.toList pvers
 178         , let pinsts' = sortBy (comparing installedUnitId) pinsts
 179               pinstsOk =
 180                 all
 181                   (\g -> length g == 1)
 182                   (groupBy (equating installedUnitId) pinsts')
 183         , pinst <- assert pinstsOk $ pinsts'
 184         , let pinstOk =
 185                 packageName pinst == pname
 186                   && packageVersion pinst == pver
 187                   && IPI.sourceLibName pinst == plib
 188         ]
 189
 190 -- If you see this invariant failing (ie the assert in mkPackageIndex below)
 191 -- then one thing to check is if it is happening in fromList. Check if the
 192 -- second list above (the sort [...] bit) is ending up with duplicates. This
 193 -- has been observed in practice once due to a messed up ghc-pkg db. How/why
 194 -- it became messed up was not discovered.
 195
 196 --
 197
 198 -- * Internal helpers
 199
 200 --
 201
 202 mkPackageIndex
 203   :: WithCallStack
 204       ( Map UnitId IPI.InstalledPackageInfo
 205         -> Map
 206             (PackageName, LibraryName)
 207             (Map Version [IPI.InstalledPackageInfo])
 208         -> InstalledPackageIndex
 209       )
 210 mkPackageIndex pids pnames = assert (invariant index) index
 211   where
 212     index = PackageIndex pids pnames
 213
 214 --
 215
 216 -- * Construction
 217
 218 --
 219
 220 -- | Build an index out of a bunch of packages.
 221 --
 222 -- If there are duplicates by 'UnitId' then later ones mask earlier
 223 -- ones.
 224 fromList :: [IPI.InstalledPackageInfo] -> InstalledPackageIndex
 225 fromList pkgs = mkPackageIndex pids ((fmap . fmap) toList pnames)
 226   where
 227     pids = Map.fromList [(installedUnitId pkg, pkg) | pkg <- pkgs]
 228     pnames =
 229       Map.fromList
 230         [ (liftM2 (,) packageName IPI.sourceLibName (NE.head pkgsN), pvers)
 231         | pkgsN <-
 232             NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName))
 233               . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion))
 234               $ pkgs
 235         , let pvers =
 236                 Map.fromList
 237                   [ ( packageVersion (NE.head pkgsNV)
 238                     , NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV)
 239                     )
 240                   | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN
 241                   ]
 242         ]
 243
 244 --
 245
 246 -- * Updates
 247
 248 --
 249
 250 -- | Merge two indexes.
 251 --
 252 -- Packages from the second mask packages from the first if they have the exact
 253 -- same 'UnitId'.
 254 --
 255 -- For packages with the same source 'PackageId', packages from the second are
 256 -- \"preferred\" over those from the first. Being preferred means they are top
 257 -- result when we do a lookup by source 'PackageId'. This is the mechanism we
 258 -- use to prefer user packages over global packages.
 259 merge
 260   :: InstalledPackageIndex
 261   -> InstalledPackageIndex
 262   -> InstalledPackageIndex
 263 merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) =
 264   mkPackageIndex
 265     (Map.unionWith (\_ y -> y) pids1 pids2)
 266     (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2)
 267   where
 268     -- Packages in the second list mask those in the first, however preferred
 269     -- packages go first in the list.
 270     mergeBuckets xs ys = ys ++ (xs \\ ys)
 271     (\\) = deleteFirstsBy (equating installedUnitId)
 272
 273 -- | Inserts a single package into the index.
 274 --
 275 -- This is equivalent to (but slightly quicker than) using 'mappend' or
 276 -- 'merge' with a singleton index.
 277 insert :: IPI.InstalledPackageInfo -> InstalledPackageIndex -> InstalledPackageIndex
 278 insert pkg (PackageIndex pids pnames) =
 279   mkPackageIndex pids' pnames'
 280   where
 281     pids' = Map.insert (installedUnitId pkg) pkg pids
 282     pnames' = insertPackageName pnames
 283     insertPackageName =
 284       Map.insertWith
 285         (\_ -> insertPackageVersion)
 286         (packageName pkg, IPI.sourceLibName pkg)
 287         (Map.singleton (packageVersion pkg) [pkg])
 288
 289     insertPackageVersion =
 290       Map.insertWith
 291         (\_ -> insertPackageInstance)
 292         (packageVersion pkg)
 293         [pkg]
 294
 295     insertPackageInstance pkgs =
 296       pkg : deleteBy (equating installedUnitId) pkg pkgs
 297
 298 -- | Removes a single installed package from the index.
 299 deleteUnitId
 300   :: UnitId
 301   -> InstalledPackageIndex
 302   -> InstalledPackageIndex
 303 deleteUnitId ipkgid original@(PackageIndex pids pnames) =
 304   case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of
 305     (Nothing, _) -> original
 306     (Just spkgid, pids') ->
 307       mkPackageIndex
 308         pids'
 309         (deletePkgName spkgid pnames)
 310   where
 311     deletePkgName spkgid =
 312       Map.update (deletePkgVersion spkgid) (packageName spkgid, IPI.sourceLibName spkgid)
 313
 314     deletePkgVersion spkgid =
 315       (\m -> if Map.null m then Nothing else Just m)
 316         . Map.update deletePkgInstance (packageVersion spkgid)
 317
 318     deletePkgInstance =
 319       (\xs -> if null xs then Nothing else Just xs)
 320         . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined
 321
 322 -- | Removes all packages with this source 'PackageId' from the index.
 323 deleteSourcePackageId
 324   :: PackageId
 325   -> InstalledPackageIndex
 326   -> InstalledPackageIndex
 327 deleteSourcePackageId pkgid original@(PackageIndex pids pnames) =
 328   -- NB: Doesn't delete internal packages
 329   case Map.lookup (packageName pkgid, LMainLibName) pnames of
 330     Nothing -> original
 331     Just pvers -> case Map.lookup (packageVersion pkgid) pvers of
 332       Nothing -> original
 333       Just pkgs ->
 334         mkPackageIndex
 335           (foldl' (flip (Map.delete . installedUnitId)) pids pkgs)
 336           (deletePkgName pnames)
 337   where
 338     deletePkgName =
 339       Map.update deletePkgVersion (packageName pkgid, LMainLibName)
 340
 341     deletePkgVersion =
 342       (\m -> if Map.null m then Nothing else Just m)
 343         . Map.delete (packageVersion pkgid)
 344
 345 -- | Removes all packages with this (case-sensitive) name from the index.
 346 --
 347 -- NB: Does NOT delete internal libraries from this package.
 348 deletePackageName
 349   :: PackageName
 350   -> InstalledPackageIndex
 351   -> InstalledPackageIndex
 352 deletePackageName name original@(PackageIndex pids pnames) =
 353   case Map.lookup (name, LMainLibName) pnames of
 354     Nothing -> original
 355     Just pvers ->
 356       mkPackageIndex
 357         ( foldl'
 358             (flip (Map.delete . installedUnitId))
 359             pids
 360             (concat (Map.elems pvers))
 361         )
 362         (Map.delete (name, LMainLibName) pnames)
 363
 364 {-
 365 -- | Removes all packages satisfying this dependency from the index.
 366 --
 367 deleteDependency :: Dependency -> PackageIndex -> PackageIndex
 368 deleteDependency (Dependency name verstionRange) =
 369   delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange)
 370 -}
 371
 372 --
 373
 374 -- * Bulk queries
 375
 376 --
 377
 378 -- | Get all the packages from the index.
 379 allPackages :: PackageIndex a -> [a]
 380 allPackages = Map.elems . unitIdIndex
 381
 382 -- | Get all the packages from the index.
 383 --
 384 -- They are grouped by package name (case-sensitively).
 385 --
 386 -- (Doesn't include private libraries.)
 387 allPackagesByName :: PackageIndex a -> [(PackageName, [a])]
 388 allPackagesByName index =
 389   [ (pkgname, concat (Map.elems pvers))
 390   | ((pkgname, LMainLibName), pvers) <- Map.toList (packageIdIndex index)
 391   ]
 392
 393 -- | Get all the packages from the index.
 394 --
 395 -- They are grouped by source package id (package name and version).
 396 --
 397 -- (Doesn't include private libraries)
 398 allPackagesBySourcePackageId
 399   :: HasUnitId a
 400   => PackageIndex a
 401   -> [(PackageId, [a])]
 402 allPackagesBySourcePackageId index =
 403   [ (packageId ipkg, ipkgs)
 404   | ((_, LMainLibName), pvers) <- Map.toList (packageIdIndex index)
 405   , ipkgs@(ipkg : _) <- Map.elems pvers
 406   ]
 407
 408 -- | Get all the packages from the index.
 409 --
 410 -- They are grouped by source package id and library name.
 411 --
 412 -- This DOES include internal libraries.
 413 allPackagesBySourcePackageIdAndLibName
 414   :: HasUnitId a
 415   => PackageIndex a
 416   -> [((PackageId, LibraryName), [a])]
 417 allPackagesBySourcePackageIdAndLibName index =
 418   [ ((packageId ipkg, ln), ipkgs)
 419   | ((_, ln), pvers) <- Map.toList (packageIdIndex index)
 420   , ipkgs@(ipkg : _) <- Map.elems pvers
 421   ]
 422
 423 --
 424
 425 -- * Lookups
 426
 427 --
 428
 429 -- | Does a lookup by unit identifier.
 430 --
 431 -- Since multiple package DBs mask each other by 'UnitId',
 432 -- then we get back at most one package.
 433 lookupUnitId
 434   :: PackageIndex a
 435   -> UnitId
 436   -> Maybe a
 437 lookupUnitId index uid = Map.lookup uid (unitIdIndex index)
 438
 439 -- | Does a lookup by component identifier.  In the absence
 440 -- of Backpack, this is just a 'lookupUnitId'.
 441 lookupComponentId
 442   :: PackageIndex a
 443   -> ComponentId
 444   -> Maybe a
 445 lookupComponentId index cid =
 446   Map.lookup (newSimpleUnitId cid) (unitIdIndex index)
 447
 448 -- | Does a lookup by source package id (name & version).
 449 --
 450 -- There can be multiple installed packages with the same source 'PackageId'
 451 -- but different 'UnitId'. They are returned in order of
 452 -- preference, with the most preferred first.
 453 lookupSourcePackageId :: PackageIndex a -> PackageId -> [a]
 454 lookupSourcePackageId index pkgid =
 455   -- Do not lookup internal libraries
 456   case Map.lookup (packageName pkgid, LMainLibName) (packageIdIndex index) of
 457     Nothing -> []
 458     Just pvers -> case Map.lookup (packageVersion pkgid) pvers of
 459       Nothing -> []
 460       Just pkgs -> pkgs -- in preference order
 461
 462 -- | Convenient alias of 'lookupSourcePackageId', but assuming only
 463 -- one package per package ID.
 464 lookupPackageId :: PackageIndex a -> PackageId -> Maybe a
 465 lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of
 466   [] -> Nothing
 467   [pkg] -> Just pkg
 468   _ -> error "Distribution.Simple.PackageIndex: multiple matches found"
 469
 470 -- | Does a lookup by source package name.
 471 lookupPackageName
 472   :: PackageIndex a
 473   -> PackageName
 474   -> [(Version, [a])]
 475 lookupPackageName index name =
 476   -- Do not match internal libraries
 477   case Map.lookup (name, LMainLibName) (packageIdIndex index) of
 478     Nothing -> []
 479     Just pvers -> Map.toList pvers
 480
 481 -- | Does a lookup by source package name and a range of versions.
 482 --
 483 -- We get back any number of versions of the specified package name, all
 484 -- satisfying the version range constraint.
 485 --
 486 -- This does NOT work for internal dependencies, DO NOT use this
 487 -- function on those; use 'lookupInternalDependency' instead.
 488 --
 489 -- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty.
 490 lookupDependency
 491   :: InstalledPackageIndex
 492   -> PackageName
 493   -> VersionRange
 494   -> [(Version, [IPI.InstalledPackageInfo])]
 495 lookupDependency index pn vr =
 496   -- Yes, a little bit of a misnomer here!
 497   lookupInternalDependency index pn vr LMainLibName
 498
 499 -- | Does a lookup by source package name and a range of versions.
 500 --
 501 -- We get back any number of versions of the specified package name, all
 502 -- satisfying the version range constraint.
 503 --
 504 -- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty.
 505 lookupInternalDependency
 506   :: InstalledPackageIndex
 507   -> PackageName
 508   -> VersionRange
 509   -> LibraryName
 510   -> [(Version, [IPI.InstalledPackageInfo])]
 511 lookupInternalDependency index name versionRange libn =
 512   case Map.lookup (name, libn) (packageIdIndex index) of
 513     Nothing -> []
 514     Just pvers ->
 515       [ (ver, pkgs')
 516       | (ver, pkgs) <- Map.toList pvers
 517       , ver `withinRange` versionRange
 518       , let pkgs' = filter eligible pkgs
 519       , -- Enforce the invariant
 520       not (null pkgs')
 521       ]
 522   where
 523     -- When we select for dependencies, we ONLY want to pick up indefinite
 524     -- packages, or packages with no instantiations.  We'll do mix-in
 525     -- linking to improve any such package into an instantiated one
 526     -- later.
 527     eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg)
 528
 529 --
 530
 531 -- * Case insensitive name lookups
 532
 533 --
 534
 535 -- | Does a case-insensitive search by package name.
 536 --
 537 -- If there is only one package that compares case-insensitively to this name
 538 -- then the search is unambiguous and we get back all versions of that package.
 539 -- If several match case-insensitively but one matches exactly then it is also
 540 -- unambiguous.
 541 --
 542 -- If however several match case-insensitively and none match exactly then we
 543 -- have an ambiguous result, and we get back all the versions of all the
 544 -- packages. The list of ambiguous results is split by exact package name. So
 545 -- it is a non-empty list of non-empty lists.
 546 searchByName :: PackageIndex a -> String -> SearchResult [a]
 547 searchByName index name =
 548   -- Don't match internal packages
 549   case [ pkgs | pkgs@((pname, LMainLibName), _) <- Map.toList (packageIdIndex index), lowercase (unPackageName pname) == lname
 550        ] of
 551     [] -> None
 552     [(_, pvers)] -> Unambiguous (concat (Map.elems pvers))
 553     pkgss -> case find ((mkPackageName name ==) . fst . fst) pkgss of
 554       Just (_, pvers) -> Unambiguous (concat (Map.elems pvers))
 555       Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss)
 556   where
 557     lname = lowercase name
 558
 559 data SearchResult a = None | Unambiguous a | Ambiguous [a]
 560
 561 -- | Does a case-insensitive substring search by package name.
 562 --
 563 -- That is, all packages that contain the given string in their name.
 564 searchByNameSubstring :: PackageIndex a -> String -> [a]
 565 searchByNameSubstring index searchterm =
 566   searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n)
 567   where
 568     lsearchterm = lowercase searchterm
 569
 570 -- | @since 3.4.0.0
 571 searchWithPredicate :: PackageIndex a -> (String -> Bool) -> [a]
 572 searchWithPredicate index predicate =
 573   [ pkg
 574   | -- Don't match internal packages
 575   ((pname, LMainLibName), pvers) <- Map.toList (packageIdIndex index)
 576   , predicate (unPackageName pname)
 577   , pkgs <- Map.elems pvers
 578   , pkg <- pkgs
 579   ]
 580
 581 --
 582
 583 -- * Special queries
 584
 585 --
 586
 587 -- None of the stuff below depends on the internal representation of the index.
 588 --
 589
 590 -- | Find if there are any cycles in the dependency graph. If there are no
 591 -- cycles the result is @[]@.
 592 --
 593 -- This actually computes the strongly connected components. So it gives us a
 594 -- list of groups of packages where within each group they all depend on each
 595 -- other, directly or indirectly.
 596 dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]]
 597 dependencyCycles index =
 598   [vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList]
 599   where
 600     adjacencyList =
 601       [ (pkg, installedUnitId pkg, installedDepends pkg)
 602       | pkg <- allPackages index
 603       ]
 604
 605 -- | All packages that have immediate dependencies that are not in the index.
 606 --
 607 -- Returns such packages along with the dependencies that they're missing.
 608 brokenPackages
 609   :: PackageInstalled a
 610   => PackageIndex a
 611   -> [(a, [UnitId])]
 612 brokenPackages index =
 613   [ (pkg, missing)
 614   | pkg <- allPackages index
 615   , let missing =
 616           [ pkg' | pkg' <- installedDepends pkg, isNothing (lookupUnitId index pkg')
 617           ]
 618   , not (null missing)
 619   ]
 620
 621 -- | Tries to take the transitive closure of the package dependencies.
 622 --
 623 -- If the transitive closure is complete then it returns that subset of the
 624 -- index. Otherwise it returns the broken packages as in 'brokenPackages'.
 625 --
 626 -- * Note that if the result is @Right []@ it is because at least one of
 627 -- the original given 'PackageId's do not occur in the index.
 628 dependencyClosure
 629   :: InstalledPackageIndex
 630   -> [UnitId]
 631   -> Either
 632       (InstalledPackageIndex)
 633       [(IPI.InstalledPackageInfo, [UnitId])]
 634 dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of
 635   (completed, []) -> Left completed
 636   (completed, _) -> Right (brokenPackages completed)
 637   where
 638     closure completed failed [] = (completed, failed)
 639     closure completed failed (pkgid : pkgids) = case lookupUnitId index pkgid of
 640       Nothing -> closure completed (pkgid : failed) pkgids
 641       Just pkg -> case lookupUnitId completed (installedUnitId pkg) of
 642         Just _ -> closure completed failed pkgids
 643         Nothing -> closure completed' failed pkgids'
 644           where
 645             completed' = insert pkg completed
 646             pkgids' = installedDepends pkg ++ pkgids
 647
 648 -- | Takes the transitive closure of the packages reverse dependencies.
 649 --
 650 -- * The given 'PackageId's must be in the index.
 651 reverseDependencyClosure
 652   :: PackageInstalled a
 653   => PackageIndex a
 654   -> [UnitId]
 655   -> [a]
 656 reverseDependencyClosure index =
 657   map vertexToPkg
 658     . concatMap Tree.flatten
 659     . Graph.dfs reverseDepGraph
 660     . map (fromMaybe noSuchPkgId . pkgIdToVertex)
 661   where
 662     (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index
 663     reverseDepGraph = Graph.transposeG depGraph
 664     noSuchPkgId = error "reverseDependencyClosure: package is not in the graph"
 665
 666 topologicalOrder :: PackageInstalled a => PackageIndex a -> [a]
 667 topologicalOrder index =
 668   map toPkgId
 669     . Graph.topSort
 670     $ graph
 671   where
 672     (graph, toPkgId, _) = dependencyGraph index
 673
 674 reverseTopologicalOrder :: PackageInstalled a => PackageIndex a -> [a]
 675 reverseTopologicalOrder index =
 676   map toPkgId
 677     . Graph.topSort
 678     . Graph.transposeG
 679     $ graph
 680   where
 681     (graph, toPkgId, _) = dependencyGraph index
 682
 683 -- | Builds a graph of the package dependencies.
 684 --
 685 -- Dependencies on other packages that are not in the index are discarded.
 686 -- You can check if there are any such dependencies with 'brokenPackages'.
 687 dependencyGraph
 688   :: PackageInstalled a
 689   => PackageIndex a
 690   -> ( Graph.Graph
 691      , Graph.Vertex -> a
 692      , UnitId -> Maybe Graph.Vertex
 693      )
 694 dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex)
 695   where
 696     graph =
 697       Array.listArray
 698         bounds
 699         [ [v | Just v <- map id_to_vertex (installedDepends pkg)]
 700         | pkg <- pkgs
 701         ]
 702
 703     pkgs = sortBy (comparing packageId) (allPackages index)
 704     vertices = zip (map installedUnitId pkgs) [0 ..]
 705     vertex_map = Map.fromList vertices
 706     id_to_vertex pid = Map.lookup pid vertex_map
 707
 708     vertex_to_pkg vertex = pkgTable ! vertex
 709
 710     pkgTable = Array.listArray bounds pkgs
 711     topBound = length pkgs - 1
 712     bounds = (0, topBound)
 713
 714 -- | We maintain the invariant that, for any 'DepUniqueKey', there
 715 -- is only one instance of the package in our database.
 716 type DepUniqueKey = (PackageName, LibraryName, Map ModuleName OpenModule)
 717
 718 -- | Given a package index where we assume we want to use all the packages
 719 -- (use 'dependencyClosure' if you need to get such a index subset) find out
 720 -- if the dependencies within it use consistent versions of each package.
 721 -- Return all cases where multiple packages depend on different versions of
 722 -- some other package.
 723 --
 724 -- Each element in the result is a package name along with the packages that
 725 -- depend on it and the versions they require. These are guaranteed to be
 726 -- distinct.
 727 dependencyInconsistencies
 728   :: InstalledPackageIndex
 729   -- At DepUniqueKey...
 730   -> [ ( DepUniqueKey
 731        , -- There were multiple packages (BAD!)
 732          [ ( UnitId
 733            , -- And here are the packages which
 734              -- immediately depended on it
 735              [IPI.InstalledPackageInfo]
 736            )
 737          ]
 738        )
 739      ]
 740 dependencyInconsistencies index = do
 741   (dep_key, insts_map) <- Map.toList inverseIndex
 742   let insts = Map.toList insts_map
 743   guard (length insts >= 2)
 744   return (dep_key, insts)
 745   where
 746     inverseIndex :: Map DepUniqueKey (Map UnitId [IPI.InstalledPackageInfo])
 747     inverseIndex = Map.fromListWith (Map.unionWith (++)) $ do
 748       pkg <- allPackages index
 749       dep_ipid <- installedDepends pkg
 750       Just dep <- [lookupUnitId index dep_ipid]
 751       let dep_key =
 752             ( packageName dep
 753             , IPI.sourceLibName dep
 754             , Map.fromList (IPI.instantiatedWith dep)
 755             )
 756       return (dep_key, Map.singleton dep_ipid [pkg])
 757
 758 -- | A rough approximation of GHC's module finder, takes a
 759 -- 'InstalledPackageIndex' and turns it into a map from module names to their
 760 -- source packages.  It's used to initialize the @build-deps@ field in @cabal
 761 -- init@.
 762 moduleNameIndex :: InstalledPackageIndex -> Map ModuleName [IPI.InstalledPackageInfo]
 763 moduleNameIndex index =
 764   Map.fromListWith (++) $ do
 765     pkg <- allPackages index
 766     IPI.ExposedModule m reexport <- IPI.exposedModules pkg
 767     case reexport of
 768       Nothing -> return (m, [pkg])
 769       Just (OpenModuleVar _) -> []
 770       Just (OpenModule _ m')
 771         | m == m' -> []
 772         | otherwise -> return (m', [pkg])
 773
 774 -- The heuristic is this: we want to prefer the original package
 775 -- which originally exported a module.  However, if a reexport
 776 -- also *renamed* the module (m /= m'), then we have to use the
 777 -- downstream package, since the upstream package has the wrong
 778 -- module name!