PackageIndex.hs 21.4 KB
Newer Older
ttuegel's avatar
ttuegel committed
1 2
{-# LANGUAGE DeriveGeneric #-}

3 4
-----------------------------------------------------------------------------
-- |
5
-- Module      :  Distribution.Simple.PackageIndex
6 7
-- Copyright   :  (c) David Himmelstrup 2005,
--                    Bjorn Bringert 2007,
Duncan Coutts's avatar
Duncan Coutts committed
8
--                    Duncan Coutts 2008-2009
9
--
Duncan Coutts's avatar
Duncan Coutts committed
10
-- Maintainer  :  cabal-devel@haskell.org
11 12
-- Portability :  portable
--
13
-- An index of packages.
Duncan Coutts's avatar
Duncan Coutts committed
14
--
15 16
module Distribution.Simple.PackageIndex (
  -- * Package index data type
17
  InstalledPackageIndex,
18
  PackageIndex,
19

20
  -- * Creating an index
21 22
  fromList,

23
  -- * Updates
24
  merge,
Duncan Coutts's avatar
Duncan Coutts committed
25

26
  insert,
Duncan Coutts's avatar
Duncan Coutts committed
27

28
  deleteComponentId,
Duncan Coutts's avatar
Duncan Coutts committed
29
  deleteSourcePackageId,
30
  deletePackageName,
Duncan Coutts's avatar
Duncan Coutts committed
31
--  deleteDependency,
32 33 34 35

  -- * Queries

  -- ** Precise lookups
36
  lookupComponentId,
Duncan Coutts's avatar
Duncan Coutts committed
37
  lookupSourcePackageId,
38
  lookupPackageId,
39
  lookupPackageName,
40 41 42 43 44 45 46 47 48 49
  lookupDependency,

  -- ** Case-insensitive searches
  searchByName,
  SearchResult(..),
  searchByNameSubstring,

  -- ** Bulk queries
  allPackages,
  allPackagesByName,
50
  allPackagesBySourcePackageId,
51 52 53 54 55 56 57 58 59 60

  -- ** Special queries
  brokenPackages,
  dependencyClosure,
  reverseDependencyClosure,
  topologicalOrder,
  reverseTopologicalOrder,
  dependencyInconsistencies,
  dependencyCycles,
  dependencyGraph,
Duncan Coutts's avatar
Duncan Coutts committed
61
  moduleNameIndex,
62 63 64
  ) where

import Control.Exception (assert)
65
import Data.Array ((!))
ttuegel's avatar
ttuegel committed
66
import qualified Data.Array as Array
67
import Distribution.Compat.Binary (Binary)
68
import Distribution.Compat.Semigroup as Semi
ttuegel's avatar
ttuegel committed
69
import qualified Data.Graph as Graph
Duncan Coutts's avatar
Duncan Coutts committed
70
import Data.List as List
71
         ( null, foldl', sort
Duncan Coutts's avatar
Duncan Coutts committed
72
         , groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy )
ttuegel's avatar
ttuegel committed
73 74
import Data.Map (Map)
import qualified Data.Map as Map
75
import Data.Maybe (isNothing, fromMaybe)
ttuegel's avatar
ttuegel committed
76 77 78
import qualified Data.Tree  as Tree
import GHC.Generics (Generic)
import Prelude hiding (lookup)
79

80
import Distribution.Package
Duncan Coutts's avatar
Duncan Coutts committed
81
         ( PackageName(..), PackageId
82
         , Package(..), packageName, packageVersion
Duncan Coutts's avatar
Duncan Coutts committed
83
         , Dependency(Dependency)--, --PackageFixedDeps(..)
84 85
         , HasComponentId(..), PackageInstalled(..)
         , ComponentId )
Duncan Coutts's avatar
Duncan Coutts committed
86 87
import Distribution.ModuleName
         ( ModuleName )
88
import Distribution.InstalledPackageInfo
89
         ( InstalledPackageInfo )
90
import qualified Distribution.InstalledPackageInfo as IPI
91
import Distribution.Version
92
         ( Version, withinRange )
Duncan Coutts's avatar
Duncan Coutts committed
93
import Distribution.Simple.Utils (lowercase, comparing, equating)
94 95

-- | The collection of information about packages from one or more 'PackageDB's.
96
-- These packages generally should have an instance of 'PackageInstalled'
97
--
98
-- Packages are uniquely identified in by their 'ComponentId', they can
Ian D. Bollinger's avatar
Ian D. Bollinger committed
99
-- also be efficiently looked up by package name or by name and version.
100
--
101
data PackageIndex a = PackageIndex
Duncan Coutts's avatar
Duncan Coutts committed
102
  -- The primary index. Each InstalledPackageInfo record is uniquely identified
103
  -- by its ComponentId.
Duncan Coutts's avatar
Duncan Coutts committed
104
  --
105
  !(Map ComponentId a)
Duncan Coutts's avatar
Duncan Coutts committed
106

Ian D. Bollinger's avatar
Ian D. Bollinger committed
107
  -- This auxiliary index maps package names (case-sensitively) to all the
Duncan Coutts's avatar
Duncan Coutts committed
108 109
  -- versions and instances of that package. This allows us to find all
  -- versions satisfying a dependency.
110
  --
Duncan Coutts's avatar
Duncan Coutts committed
111 112
  -- It is a three-level index. The first level is the package name,
  -- the second is the package version and the final level is instances
113
  -- of the same package version. These are unique by ComponentId
Duncan Coutts's avatar
Duncan Coutts committed
114
  -- and are kept in preference order.
115
  --
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
116 117
  -- FIXME: Clarify what "preference order" means. Check that this invariant is
  -- preserved. See #1463 for discussion.
118
  !(Map PackageName (Map Version [a]))
119

120
  deriving (Eq, Generic, Show, Read)
ttuegel's avatar
ttuegel committed
121 122

instance Binary a => Binary (PackageIndex a)
Duncan Coutts's avatar
Duncan Coutts committed
123

124 125 126 127
-- | The default package index which contains 'InstalledPackageInfo'.  Normally
-- use this.
type InstalledPackageIndex = PackageIndex InstalledPackageInfo

128
instance HasComponentId a => Monoid (PackageIndex a) where
Duncan Coutts's avatar
Duncan Coutts committed
129
  mempty  = PackageIndex Map.empty Map.empty
130
  mappend = (Semi.<>)
131
  --save one mappend with empty in the common case:
132
  mconcat [] = mempty
133 134
  mconcat xs = foldr1 mappend xs

135 136 137
instance HasComponentId a => Semigroup (PackageIndex a) where
  (<>) = merge

138
invariant :: HasComponentId a => PackageIndex a -> Bool
Duncan Coutts's avatar
Duncan Coutts committed
139
invariant (PackageIndex pids pnames) =
140
     map installedComponentId (Map.elems pids)
141
  == sort
142
     [ assert pinstOk (installedComponentId pinst)
Duncan Coutts's avatar
Duncan Coutts committed
143 144 145
     | (pname, pvers)  <- Map.toList pnames
     , let pversOk = not (Map.null pvers)
     , (pver,  pinsts) <- assert pversOk $ Map.toList pvers
146
     , let pinsts'  = sortBy (comparing installedComponentId) pinsts
Duncan Coutts's avatar
Duncan Coutts committed
147
           pinstsOk = all (\g -> length g == 1)
148
                          (groupBy (equating installedComponentId) pinsts')
Duncan Coutts's avatar
Duncan Coutts committed
149 150 151 152 153
     , pinst           <- assert pinstsOk $ pinsts'
     , let pinstOk = packageName    pinst == pname
                  && packageVersion pinst == pver
     ]

154

155 156 157 158
--
-- * Internal helpers
--

159 160
mkPackageIndex :: HasComponentId a
               => Map ComponentId a
161 162
               -> Map PackageName (Map Version [a])
               -> PackageIndex a
Duncan Coutts's avatar
Duncan Coutts committed
163 164
mkPackageIndex pids pnames = assert (invariant index) index
  where index = PackageIndex pids pnames
165

166 167 168

--
-- * Construction
169 170
--

171
-- | Build an index out of a bunch of packages.
172
--
173
-- If there are duplicates by 'ComponentId' then later ones mask earlier
Duncan Coutts's avatar
Duncan Coutts committed
174
-- ones.
175
--
176
fromList :: HasComponentId a => [a] -> PackageIndex a
Duncan Coutts's avatar
Duncan Coutts committed
177
fromList pkgs = mkPackageIndex pids pnames
178
  where
179
    pids      = Map.fromList [ (installedComponentId pkg, pkg) | pkg <- pkgs ]
Duncan Coutts's avatar
Duncan Coutts committed
180 181 182 183 184 185 186 187 188
    pnames    =
      Map.fromList
        [ (packageName (head pkgsN), pvers)
        | pkgsN <- groupBy (equating  packageName)
                 . sortBy  (comparing packageId)
                 $ pkgs
        , let pvers =
                Map.fromList
                [ (packageVersion (head pkgsNV),
189
                   nubBy (equating installedComponentId) (reverse pkgsNV))
Duncan Coutts's avatar
Duncan Coutts committed
190 191 192
                | pkgsNV <- groupBy (equating packageVersion) pkgsN
                ]
        ]
193

194 195 196 197
--
-- * Updates
--

198 199
-- | Merge two indexes.
--
Duncan Coutts's avatar
Duncan Coutts committed
200
-- Packages from the second mask packages from the first if they have the exact
201
-- same 'ComponentId'.
202
--
Duncan Coutts's avatar
Duncan Coutts committed
203 204 205 206 207
-- For packages with the same source 'PackageId', packages from the second are
-- \"preferred\" over those from the first. Being preferred means they are top
-- result when we do a lookup by source 'PackageId'. This is the mechanism we
-- use to prefer user packages over global packages.
--
208
merge :: HasComponentId a => PackageIndex a -> PackageIndex a
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
209
      -> PackageIndex a
Duncan Coutts's avatar
Duncan Coutts committed
210
merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) =
211
  mkPackageIndex (Map.unionWith (\_ y -> y) pids1 pids2)
Duncan Coutts's avatar
Duncan Coutts committed
212 213 214 215 216
                 (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2)
  where
    -- Packages in the second list mask those in the first, however preferred
    -- packages go first in the list.
    mergeBuckets xs ys = ys ++ (xs \\ ys)
217
    (\\) = deleteFirstsBy (equating installedComponentId)
218

219

Duncan Coutts's avatar
Duncan Coutts committed
220
-- | Inserts a single package into the index.
221 222 223 224
--
-- This is equivalent to (but slightly quicker than) using 'mappend' or
-- 'merge' with a singleton index.
--
225
insert :: HasComponentId a => a -> PackageIndex a -> PackageIndex a
Duncan Coutts's avatar
Duncan Coutts committed
226 227 228
insert pkg (PackageIndex pids pnames) =
    mkPackageIndex pids' pnames'

229
  where
230
    pids'   = Map.insert (installedComponentId pkg) pkg pids
Duncan Coutts's avatar
Duncan Coutts committed
231 232 233 234 235 236 237 238 239 240 241
    pnames' = insertPackageName pnames
    insertPackageName =
      Map.insertWith' (\_ -> insertPackageVersion)
                     (packageName pkg)
                     (Map.singleton (packageVersion pkg) [pkg])

    insertPackageVersion =
      Map.insertWith' (\_ -> insertPackageInstance)
                     (packageVersion pkg) [pkg]

    insertPackageInstance pkgs =
242
      pkg : deleteBy (equating installedComponentId) pkg pkgs
Duncan Coutts's avatar
Duncan Coutts committed
243 244 245 246


-- | Removes a single installed package from the index.
--
247 248
deleteComponentId :: HasComponentId a
                         => ComponentId -> PackageIndex a
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
249
                         -> PackageIndex a
250
deleteComponentId ipkgid original@(PackageIndex pids pnames) =
Duncan Coutts's avatar
Duncan Coutts committed
251 252 253 254 255
  case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of
    (Nothing,     _)     -> original
    (Just spkgid, pids') -> mkPackageIndex pids'
                                          (deletePkgName spkgid pnames)

Duncan Coutts's avatar
Duncan Coutts committed
256
  where
Duncan Coutts's avatar
Duncan Coutts committed
257 258 259 260 261 262
    deletePkgName spkgid =
      Map.update (deletePkgVersion spkgid) (packageName spkgid)

    deletePkgVersion spkgid =
        (\m -> if Map.null m then Nothing else Just m)
      . Map.update deletePkgInstance (packageVersion spkgid)
Duncan Coutts's avatar
Duncan Coutts committed
263

Duncan Coutts's avatar
Duncan Coutts committed
264 265
    deletePkgInstance =
        (\xs -> if List.null xs then Nothing else Just xs)
266
      . List.deleteBy (\_ pkg -> installedComponentId pkg == ipkgid) undefined
Duncan Coutts's avatar
Duncan Coutts committed
267 268 269


-- | Removes all packages with this source 'PackageId' from the index.
270
--
271
deleteSourcePackageId :: HasComponentId a => PackageId -> PackageIndex a
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
272
                      -> PackageIndex a
Duncan Coutts's avatar
Duncan Coutts committed
273 274 275 276 277 278
deleteSourcePackageId pkgid original@(PackageIndex pids pnames) =
  case Map.lookup (packageName pkgid) pnames of
    Nothing     -> original
    Just pvers  -> case Map.lookup (packageVersion pkgid) pvers of
      Nothing   -> original
      Just pkgs -> mkPackageIndex
279
                     (foldl' (flip (Map.delete . installedComponentId)) pids pkgs)
Duncan Coutts's avatar
Duncan Coutts committed
280 281 282 283 284 285 286 287 288
                     (deletePkgName pnames)
  where
    deletePkgName =
      Map.update deletePkgVersion (packageName pkgid)

    deletePkgVersion =
        (\m -> if Map.null m then Nothing else Just m)
      . Map.delete (packageVersion pkgid)

289 290 291

-- | Removes all packages with this (case-sensitive) name from the index.
--
292
deletePackageName :: HasComponentId a => PackageName -> PackageIndex a
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
293
                  -> PackageIndex a
Duncan Coutts's avatar
Duncan Coutts committed
294 295 296 297
deletePackageName name original@(PackageIndex pids pnames) =
  case Map.lookup name pnames of
    Nothing     -> original
    Just pvers  -> mkPackageIndex
298
                     (foldl' (flip (Map.delete . installedComponentId)) pids
Duncan Coutts's avatar
Duncan Coutts committed
299 300
                             (concat (Map.elems pvers)))
                     (Map.delete name pnames)
301

Duncan Coutts's avatar
Duncan Coutts committed
302
{-
303 304
-- | Removes all packages satisfying this dependency from the index.
--
Duncan Coutts's avatar
Duncan Coutts committed
305
deleteDependency :: Dependency -> PackageIndex -> PackageIndex
306
deleteDependency (Dependency name verstionRange) =
Duncan Coutts's avatar
Duncan Coutts committed
307 308
  delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange)
-}
309

310 311 312 313
--
-- * Bulk queries
--

314 315
-- | Get all the packages from the index.
--
316
allPackages :: PackageIndex a -> [a]
Duncan Coutts's avatar
Duncan Coutts committed
317
allPackages (PackageIndex pids _) = Map.elems pids
318 319 320

-- | Get all the packages from the index.
--
321
-- They are grouped by package name (case-sensitively).
322
--
323
allPackagesByName :: PackageIndex a -> [(PackageName, [a])]
Duncan Coutts's avatar
Duncan Coutts committed
324
allPackagesByName (PackageIndex _ pnames) =
325 326 327 328 329 330 331
  [ (pkgname, concat (Map.elems pvers))
  | (pkgname, pvers) <- Map.toList pnames ]

-- | Get all the packages from the index.
--
-- They are grouped by source package id (package name and version).
--
332
allPackagesBySourcePackageId :: HasComponentId a => PackageIndex a
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
333
                             -> [(PackageId, [a])]
334 335 336 337
allPackagesBySourcePackageId (PackageIndex _ pnames) =
  [ (packageId ipkg, ipkgs)
  | pvers <- Map.elems pnames
  , ipkgs@(ipkg:_) <- Map.elems pvers ]
338 339 340 341 342

--
-- * Lookups
--

Duncan Coutts's avatar
Duncan Coutts committed
343
-- | Does a lookup by source package id (name & version).
344
--
345
-- Since multiple package DBs mask each other by 'ComponentId',
346 347
-- then we get back at most one package.
--
348
lookupComponentId :: PackageIndex a -> ComponentId
349
                         -> Maybe a
350
lookupComponentId (PackageIndex pids _) pid = Map.lookup pid pids
Duncan Coutts's avatar
Duncan Coutts committed
351

352

Duncan Coutts's avatar
Duncan Coutts committed
353 354 355
-- | Does a lookup by source package id (name & version).
--
-- There can be multiple installed packages with the same source 'PackageId'
356
-- but different 'ComponentId'. They are returned in order of
Duncan Coutts's avatar
Duncan Coutts committed
357
-- preference, with the most preferred first.
358
--
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
359
lookupSourcePackageId :: PackageIndex a -> PackageId -> [a]
Duncan Coutts's avatar
Duncan Coutts committed
360 361 362 363 364 365
lookupSourcePackageId (PackageIndex _ pnames) pkgid =
  case Map.lookup (packageName pkgid) pnames of
    Nothing     -> []
    Just pvers  -> case Map.lookup (packageVersion pkgid) pvers of
      Nothing   -> []
      Just pkgs -> pkgs -- in preference order
366

367 368
-- | Convenient alias of 'lookupSourcePackageId', but assuming only
-- one package per package ID.
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
369
lookupPackageId :: PackageIndex a -> PackageId -> Maybe a
370 371 372 373
lookupPackageId index pkgid = case lookupSourcePackageId index pkgid  of
    []    -> Nothing
    [pkg] -> Just pkg
    _     -> error "Distribution.Simple.PackageIndex: multiple matches found"
Duncan Coutts's avatar
Duncan Coutts committed
374 375 376

-- | Does a lookup by source package name.
--
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
377
lookupPackageName :: PackageIndex a -> PackageName
378
                  -> [(Version, [a])]
Duncan Coutts's avatar
Duncan Coutts committed
379 380 381 382 383 384 385
lookupPackageName (PackageIndex _ pnames) name =
  case Map.lookup name pnames of
    Nothing     -> []
    Just pvers  -> Map.toList pvers


-- | Does a lookup by source package name and a range of versions.
386 387 388 389
--
-- We get back any number of versions of the specified package name, all
-- satisfying the version range constraint.
--
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
390
lookupDependency :: PackageIndex a -> Dependency
391
                 -> [(Version, [a])]
Duncan Coutts's avatar
Duncan Coutts committed
392 393 394 395 396 397
lookupDependency (PackageIndex _ pnames) (Dependency name versionRange) =
  case Map.lookup name pnames of
    Nothing    -> []
    Just pvers -> [ entry
                  | entry@(ver, _) <- Map.toList pvers
                  , ver `withinRange` versionRange ]
398 399 400 401

--
-- * Case insensitive name lookups
--
402 403 404

-- | Does a case-insensitive search by package name.
--
Ian D. Bollinger's avatar
Ian D. Bollinger committed
405
-- If there is only one package that compares case-insensitively to this name
406
-- then the search is unambiguous and we get back all versions of that package.
Ian D. Bollinger's avatar
Ian D. Bollinger committed
407
-- If several match case-insensitively but one matches exactly then it is also
408 409
-- unambiguous.
--
Ian D. Bollinger's avatar
Ian D. Bollinger committed
410
-- If however several match case-insensitively and none match exactly then we
411 412 413 414
-- have an ambiguous result, and we get back all the versions of all the
-- packages. The list of ambiguous results is split by exact package name. So
-- it is a non-empty list of non-empty lists.
--
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
415
searchByName :: PackageIndex a -> String -> SearchResult [a]
Duncan Coutts's avatar
Duncan Coutts committed
416 417
searchByName (PackageIndex _ pnames) name =
  case [ pkgs | pkgs@(PackageName name',_) <- Map.toList pnames
418
              , lowercase name' == lname ] of
Duncan Coutts's avatar
Duncan Coutts committed
419 420 421 422 423
    []               -> None
    [(_,pvers)]      -> Unambiguous (concat (Map.elems pvers))
    pkgss            -> case find ((PackageName name==) . fst) pkgss of
      Just (_,pvers) -> Unambiguous (concat (Map.elems pvers))
      Nothing        -> Ambiguous (map (concat . Map.elems . snd) pkgss)
424
  where lname = lowercase name
425 426 427 428 429 430 431

data SearchResult a = None | Unambiguous a | Ambiguous [a]

-- | Does a case-insensitive substring search by package name.
--
-- That is, all packages that contain the given string in their name.
--
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
432
searchByNameSubstring :: PackageIndex a -> String -> [a]
Duncan Coutts's avatar
Duncan Coutts committed
433
searchByNameSubstring (PackageIndex _ pnames) searchterm =
434
  [ pkg
Duncan Coutts's avatar
Duncan Coutts committed
435
  | (PackageName name, pvers) <- Map.toList pnames
436
  , lsearchterm `isInfixOf` lowercase name
Duncan Coutts's avatar
Duncan Coutts committed
437
  , pkgs <- Map.elems pvers
438
  , pkg <- pkgs ]
439
  where lsearchterm = lowercase searchterm
440

Duncan Coutts's avatar
Duncan Coutts committed
441 442 443 444 445 446 447 448

--
-- * Special queries
--

-- None of the stuff below depends on the internal representation of the index.
--

449 450 451 452 453 454 455
-- | Find if there are any cycles in the dependency graph. If there are no
-- cycles the result is @[]@.
--
-- This actually computes the strongly connected components. So it gives us a
-- list of groups of packages where within each group they all depend on each
-- other, directly or indirectly.
--
456
dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]]
457
dependencyCycles index =
458 459
  [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]
  where
460
    adjacencyList = [ (pkg, installedComponentId pkg, installedDepends pkg)
461 462 463
                    | pkg <- allPackages index ]


Duncan Coutts's avatar
Duncan Coutts committed
464
-- | All packages that have immediate dependencies that are not in the index.
465
--
466 467
-- Returns such packages along with the dependencies that they're missing.
--
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
468
brokenPackages :: PackageInstalled a => PackageIndex a
469
               -> [(a, [ComponentId])]
470
brokenPackages index =
471
  [ (pkg, missing)
Duncan Coutts's avatar
Duncan Coutts committed
472
  | pkg  <- allPackages index
473
  , let missing = [ pkg' | pkg' <- installedDepends pkg
474
                         , isNothing (lookupComponentId index pkg') ]
475 476
  , not (null missing) ]

477
-- | Tries to take the transitive closure of the package dependencies.
478
--
479
-- If the transitive closure is complete then it returns that subset of the
480 481 482
-- index. Otherwise it returns the broken packages as in 'brokenPackages'.
--
-- * Note that if the result is @Right []@ it is because at least one of
Duncan Coutts's avatar
Duncan Coutts committed
483
-- the original given 'PackageId's do not occur in the index.
484
--
485
dependencyClosure :: PackageInstalled a => PackageIndex a
486
                  -> [ComponentId]
487
                  -> Either (PackageIndex a)
488
                            [(a, [ComponentId])]
489
dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of
490 491
  (completed, []) -> Left completed
  (completed, _)  -> Right (brokenPackages completed)
492
 where
493
    closure completed failed []             = (completed, failed)
494
    closure completed failed (pkgid:pkgids) = case lookupComponentId index pkgid of
495
      Nothing   -> closure completed (pkgid:failed) pkgids
496
      Just pkg  -> case lookupComponentId completed (installedComponentId pkg) of
497 498
        Just _  -> closure completed  failed pkgids
        Nothing -> closure completed' failed pkgids'
Duncan Coutts's avatar
Duncan Coutts committed
499
          where completed' = insert pkg completed
500
                pkgids'    = installedDepends pkg ++ pkgids
501

502
-- | Takes the transitive closure of the packages reverse dependencies.
503
--
Duncan Coutts's avatar
Duncan Coutts committed
504
-- * The given 'PackageId's must be in the index.
505
--
506
reverseDependencyClosure :: PackageInstalled a => PackageIndex a
507
                         -> [ComponentId]
508
                         -> [a]
509
reverseDependencyClosure index =
510 511 512 513
    map vertexToPkg
  . concatMap Tree.flatten
  . Graph.dfs reverseDepGraph
  . map (fromMaybe noSuchPkgId . pkgIdToVertex)
514

515
  where
516
    (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index
517 518 519
    reverseDepGraph = Graph.transposeG depGraph
    noSuchPkgId = error "reverseDependencyClosure: package is not in the graph"

520
topologicalOrder :: PackageInstalled a => PackageIndex a -> [a]
521 522 523 524 525
topologicalOrder index = map toPkgId
                       . Graph.topSort
                       $ graph
  where (graph, toPkgId, _) = dependencyGraph index

526
reverseTopologicalOrder :: PackageInstalled a => PackageIndex a -> [a]
527 528 529 530 531 532 533 534 535 536 537
reverseTopologicalOrder index = map toPkgId
                              . Graph.topSort
                              . Graph.transposeG
                              $ graph
  where (graph, toPkgId, _) = dependencyGraph index

-- | 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'.
--
538
dependencyGraph :: PackageInstalled a => PackageIndex a
539
                -> (Graph.Graph,
540
                    Graph.Vertex -> a,
541
                    ComponentId -> Maybe Graph.Vertex)
542
dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex)
543 544
  where
    graph = Array.listArray bounds
545
              [ [ v | Just v <- map id_to_vertex (installedDepends pkg) ]
546
              | pkg <- pkgs ]
547

Duncan Coutts's avatar
Duncan Coutts committed
548
    pkgs             = sortBy (comparing packageId) (allPackages index)
549
    vertices         = zip (map installedComponentId pkgs) [0..]
550
    vertex_map       = Map.fromList vertices
551
    id_to_vertex pid = Map.lookup pid vertex_map
552 553

    vertex_to_pkg vertex = pkgTable ! vertex
554 555 556 557 558

    pkgTable   = Array.listArray bounds pkgs
    topBound = length pkgs - 1
    bounds = (0, topBound)

559 560 561 562 563 564 565 566 567 568
-- | Given a package index where we assume we want to use all the packages
-- (use 'dependencyClosure' if you need to get such a index subset) find out
-- if the dependencies within it use consistent versions of each package.
-- Return all cases where multiple packages depend on different versions of
-- some other package.
--
-- Each element in the result is a package name along with the packages that
-- depend on it and the versions they require. These are guaranteed to be
-- distinct.
--
569
dependencyInconsistencies :: PackageInstalled a => PackageIndex a
Duncan Coutts's avatar
Duncan Coutts committed
570
                          -> [(PackageName, [(PackageId, Version)])]
571
dependencyInconsistencies index =
572 573 574 575 576 577 578 579 580 581 582 583
  [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids])
  | (name, ipid_map) <- Map.toList inverseIndex
  , let uses = Map.elems ipid_map
  , reallyIsInconsistent (map fst uses) ]

  where -- for each PackageName,
        --   for each package with that name,
        --     the InstalledPackageInfo and the package Ids of packages
        --     that depend on it.
        inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))
          [ (packageName dep,
             Map.fromList [(ipid,(dep,[packageId pkg]))])
Duncan Coutts's avatar
Duncan Coutts committed
584
          | pkg <- allPackages index
585
          , ipid <- installedDepends pkg
586
          , Just dep <- [lookupComponentId index ipid]
587 588
          ]

589
        reallyIsInconsistent :: PackageInstalled a => [a] -> Bool
590 591 592
        reallyIsInconsistent []       = False
        reallyIsInconsistent [_p]     = False
        reallyIsInconsistent [p1, p2] =
593 594
          let pid1 = installedComponentId p1
              pid2 = installedComponentId p2
595 596
          in pid1 `notElem` installedDepends p2
          && pid2 `notElem` installedDepends p1
597
        reallyIsInconsistent _ = True
Duncan Coutts's avatar
Duncan Coutts committed
598

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
599 600 601 602
-- | 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 initialize the @build-deps@ field in @cabal
-- init@.
603
moduleNameIndex :: InstalledPackageIndex -> Map ModuleName [InstalledPackageInfo]
Duncan Coutts's avatar
Duncan Coutts committed
604
moduleNameIndex index =
605 606 607 608 609 610 611
  Map.fromListWith (++) $ do
    pkg <- allPackages index
    IPI.ExposedModule m reexport _ <- IPI.exposedModules pkg
    case reexport of
        Nothing -> return (m, [pkg])
        Just (IPI.OriginalModule _ m') | m == m'   -> []
                                       | otherwise -> return (m', [pkg])
612 613 614 615 616
        -- The heuristic is this: we want to prefer the original package
        -- which originally exported a module.  However, if a reexport
        -- also *renamed* the module (m /= m'), then we have to use the
        -- downstream package, since the upstream package has the wrong
        -- module name!