PackageIndex.hs 11.8 KB
Newer Older
1
2
-----------------------------------------------------------------------------
-- |
3
-- Module      :  Distribution.Simple.PackageIndex
4
5
6
7
8
9
10
11
12
-- Copyright   :  (c) David Himmelstrup 2005,
--                    Bjorn Bringert 2007,
--                    Duncan Coutts 2008
-- License     :  BSD-like
--
-- Maintainer  :  Duncan Coutts <duncan@haskell.org>
-- Stability   :  provisional
-- Portability :  portable
--
13
-- An index of packages.
14
-----------------------------------------------------------------------------
15
16
17
18
19
20
module Distribution.Simple.PackageIndex (
  -- * Package classes
  Package(..),

  -- * Package index data type
  PackageIndex,
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41

  -- * Creating the index
  fromList,

  -- * Merging indexes
  merge,

  -- * Queries

  -- ** Precise lookups
  lookupPackageId,
  lookupDependency,

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

  -- ** Bulk queries
  allPackages,
  allPackagesByName,
42
43
44
45
46

  -- ** Special queries
  brokenPackages,
  dependencyClosure,
  dependencyInconsistencies
47
48
49
50
51
52
53
54
  ) where

import Prelude hiding (lookup)
import Control.Exception (assert)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.List (nubBy, group, sort, groupBy, sortBy, find)
import Data.Monoid (Monoid(..))
55
import Data.Maybe (isNothing)
56
57
58

import Distribution.Package (PackageIdentifier(..))
import Distribution.InstalledPackageInfo
59
         ( InstalledPackageInfo_ )
60
61
62
63
64
65
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
         ( InstalledPackageInfo_(..) )
import Distribution.PackageDescription
         ( PackageDescription )
import qualified Distribution.PackageDescription as PackageDescription
         ( PackageDescription(..) )
66
import Distribution.Version (Version, Dependency(Dependency), withinRange)
67
68
import Distribution.Simple.Utils (lowercase, equating, comparing, isInfixOf)

69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
-- | Class of things that can be identified by a 'PackageIdentifier'
--
-- Types in this class are all notions of a package. This allows us to have
-- different types for the different phases that packages go though, from
-- simple name\/id, package description, configured or installed packages.
--
class Package pkg where
  packageId :: pkg -> PackageIdentifier

instance Package PackageIdentifier where
  packageId = id
instance Package (InstalledPackageInfo_ str) where
  packageId = InstalledPackageInfo.package
instance Package PackageDescription where
  packageId = PackageDescription.package

85
86
87
88
89
90
91
92
93
94
95
96
97
-- | 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]

instance PackageFixedDeps (InstalledPackageInfo_ str) where
  depends = InstalledPackageInfo.depends

98
99
100
101
-- | The collection of information about packages from one or more 'PackageDB's.
--
-- It can be searched effeciently by package name and version.
--
102
data Package pkg => PackageIndex pkg = PackageIndex
Duncan Coutts's avatar
Duncan Coutts committed
103
  -- This index maps lower case package names to all the
104
105
106
107
108
109
110
  -- 'InstalledPackageInfo' records matching that package name
  -- case-insensitively. It includes all versions.
  --
  -- This allows us to do case sensitive or insensitive lookups, and to find
  -- all versions satisfying a dependency, all by varying how we filter. So
  -- most queries will do a map lookup followed by a linear scan of the bucket.
  --
111
  (Map String [pkg])
112
113
114

  deriving (Show, Read)

115
116
instance Package pkg => Monoid (PackageIndex pkg) where
  mempty  = PackageIndex (Map.empty)
117
118
119
120
121
  mappend = merge
  --save one mappend with empty in the common case:
  mconcat [] = mempty
  mconcat xs = foldr1 mappend xs

122
123
invariant :: Package pkg => PackageIndex pkg -> Bool
invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)
124
125
126
  where goodBucket name pkgs =
             lowercase name == name
          && not (null pkgs)
127
          && all ((lowercase name==) . lowercase . pkgName . packageId) pkgs
128
--          && all (\pkg -> pkgInfoId pkg
129
130
--                       == (packageId . packageDescription . pkgDesc) pkg) pkgs
          && distinct (map packageId pkgs)
131
132
133
134

        distinct = all ((==1). length) . group . sort

internalError :: String -> a
135
internalError name = error ("PackageIndex." ++ name ++ ": internal error")
136
137
138
139

-- | When building or merging we have to eliminate duplicates of the exact
-- same package name and version (case-sensitively) to preserve the invariant.
--
140
141
stripDups :: Package pkg => [pkg] -> [pkg]
stripDups = nubBy (equating packageId)
142
143
144
145

-- | Lookup a name in the index to get all packages that match that name
-- case-insensitively.
--
146
147
lookup :: Package pkg => PackageIndex pkg -> String -> [pkg]
lookup index@(PackageIndex m) name =
148
149
150
151
152
  assert (invariant index) $
  case Map.lookup (lowercase name) m of
    Nothing   -> []
    Just pkgs -> pkgs

153
-- | Build an index out of a bunch of 'Package's.
154
155
156
--
-- If there are duplicates, earlier ones mask later one.
--
157
fromList :: Package pkg => [pkg] -> PackageIndex pkg
158
fromList pkgs =
159
160
  let index = (PackageIndex . Map.map stripDups . Map.fromListWith (++))
                [ let key = (lowercase . pkgName . packageId) pkg
161
162
163
164
165
166
167
168
169
                   in (key, [pkg])
                | pkg <- pkgs ]
   in assert (invariant index) index

-- | Merge two indexes.
--
-- Packages from the first mask packages of the same exact name
-- (case-sensitively) from the second.
--
170
171
merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg
merge i1@(PackageIndex m1) i2@(PackageIndex m2) =
172
  assert (invariant i1 && invariant i2) $
173
  let index = PackageIndex (Map.unionWith mergeBuckets m1 m2)
174
175
176
177
178
179
   in assert (invariant index) index

  where mergeBuckets pkgs1 pkgs2 = stripDups (pkgs1 ++ pkgs2)

-- | Get all the packages from the index.
--
180
181
allPackages :: Package pkg => PackageIndex pkg -> [pkg]
allPackages (PackageIndex m) = concat (Map.elems m)
182
183
184
185
186

-- | Get all the packages from the index.
--
-- They are grouped by package name, case-sensitively.
--
187
188
189
190
191
allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]]
allPackagesByName (PackageIndex m) = concatMap groupByName (Map.elems m)
  where groupByName :: Package pkg => [pkg] -> [[pkg]]
        groupByName = groupBy (equating (pkgName . packageId))
                    . sortBy (comparing (pkgName . packageId))
192
193
194
195
196
197
198
199
200
201
202
203
204

-- | Does a case-insensitive search by package name.
--
-- If there is only one package that compares case-insentiviely to this name
-- then the search is unambiguous and we get back all versions of that package.
-- If several match case-insentiviely but one matches exactly then it is also
-- unambiguous.
--
-- If however several match case-insentiviely and none match exactly then we
-- 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.
--
205
searchByName :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg]
206
searchByName index name =
207
208
  case groupBy (equating  (pkgName . packageId))
     . sortBy  (comparing (pkgName . packageId))
209
210
211
     $ lookup index name of
    []     -> None
    [pkgs] -> Unambiguous pkgs
212
    pkgss  -> case find ((name==) . pkgName . packageId . head) pkgss of
213
214
215
216
217
218
219
220
221
                Just pkgs -> Unambiguous pkgs
                Nothing   -> Ambiguous   pkgss

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.
--
222
223
searchByNameSubstring :: Package pkg => PackageIndex pkg -> String -> [pkg]
searchByNameSubstring (PackageIndex m) searchterm =
224
225
226
227
228
229
230
231
232
233
234
  [ pkg
  | (name, pkgs) <- Map.toList m
  , searchterm' `isInfixOf` name
  , pkg <- pkgs ]
  where searchterm' = lowercase searchterm

-- | Does a lookup by package id (name & version).
--
-- Since multiple package DBs mask each other case-sensitively by package name,
-- then we get back at most one package.
--
235
lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg
236
237
lookupPackageId index pkgid =
  case [ pkg | pkg <- lookup index (pkgName pkgid)
238
             , packageId pkg == pkgid ] of
239
240
241
242
243
244
245
246
247
    []    -> Nothing
    [pkg] -> Just pkg
    _     -> internalError "lookupPackageIdentifier"

-- | Does a case-sensitive search by package name and a range of versions.
--
-- We get back any number of versions of the specified package name, all
-- satisfying the version range constraint.
--
248
lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg]
249
lookupDependency index (Dependency name versionRange) =
250
251
  [ pkg | pkg <- lookup index name
        , let pkgid = packageId pkg
252
253
        , pkgName pkgid == name
        , pkgVersion pkgid `withinRange` versionRange ]
254
255
256
257
258

-- | All packages that have depends that are not in the index.
--
-- Returns such packages along with the depends that they're missing.
--
259
260
261
brokenPackages :: PackageFixedDeps pkg
               => PackageIndex pkg
               -> [(pkg, [PackageIdentifier])]
262
263
264
brokenPackages index =
  [ (pkg, missing)
  | pkg  <- allPackages index
265
  , let missing = [ pkg' | pkg' <- depends pkg
266
267
268
269
270
271
272
273
274
275
276
                         , isNothing (lookupPackageId index pkg') ]
  , not (null missing) ]

-- | Tries to take the transative closure of the package dependencies.
--
-- If the transative closure is complete then it returns that subset of the
-- index. Otherwise it returns the broken packages as in 'brokenPackages'.
--
-- * Note that if any of the result is @Right []@ it is because at least one of
-- the original given 'PackageIdentifier's do not occur in the index.
--
277
278
dependencyClosure :: PackageFixedDeps pkg
                  => PackageIndex pkg
279
                  -> [PackageIdentifier]
280
281
                  -> Either (PackageIndex pkg)
                            [(pkg, [PackageIdentifier])]
282
283
284
285
286
287
288
289
290
dependencyClosure index pkgids0 = case closure [] [] pkgids0 of
  (completed, []) -> Left  $ fromList completed
  (completed, _)  -> Right $ brokenPackages (fromList completed)

  where
    closure completed failed [] = (completed, failed)
    closure completed failed (pkgid:pkgids) = case lookupPackageId index pkgid of
      Nothing  -> closure completed (pkgid:failed) pkgids
               -- TODO: use more effecient test here:
291
      Just pkg | packageId pkg `elem` map packageId completed
292
293
               -> closure      completed   failed  pkgids
               | otherwise
294
               -> closure (pkg:completed)  failed  pkgids'
295
               where pkgids' = depends pkg ++ pkgids
296
297
298
299
300
301
302
303
304
305
306

-- | 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.
--
307
308
309
dependencyInconsistencies :: PackageFixedDeps pkg
                          => PackageIndex pkg
                          -> pkg
310
                          -> [(String, [(PackageIdentifier, Version)])]
311
dependencyInconsistencies index topPkg =
312
313
314
315
316
  [ (name, inconsistencies)
  | (name, uses) <- Map.toList inverseIndex
  , let inconsistencies = duplicatesBy uses
  , not (null inconsistencies) ]

317
318
319
320
  where inverseIndex = Map.fromListWith (++)
          [ (pkgName dep, [(packageId pkg, pkgVersion dep)])
          | pkg <- topPkg : allPackages index
          , dep <- depends pkg ]
321
322
323
324
325
326

        duplicatesBy = (\groups -> if length groups == 1
                                     then []
                                     else concat groups)
                     . groupBy (equating snd)
                     . sortBy (comparing snd)