PackageIndex.hs 11.8 KB
Newer Older
1
2
-----------------------------------------------------------------------------
-- |
3
-- Module      :  Distribution.Simple.PackageIndex
4
5
6
7
8
9
10
11
12
13
14
-- Copyright   :  (c) David Himmelstrup 2005,
--                    Bjorn Bringert 2007,
--                    Duncan Coutts 2008
-- License     :  BSD-like
--
-- Maintainer  :  Duncan Coutts <duncan@haskell.org>
-- Stability   :  provisional
-- Portability :  portable
--
-- The index of 'InstalledPackageInfo'.
-----------------------------------------------------------------------------
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
60
61
62
63
64
65
         ( InstalledPackageInfo, InstalledPackageInfo_, emptyInstalledPackageInfo )
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
-- | The collection of information about packages from one or more 'PackageDB's.
--
-- It can be searched effeciently by package name and version.
--
89
data Package pkg => PackageIndex pkg = PackageIndex
Duncan Coutts's avatar
Duncan Coutts committed
90
  -- This index maps lower case package names to all the
91
92
93
94
95
96
97
  -- '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.
  --
98
  (Map String [pkg])
99
100
101

  deriving (Show, Read)

102
103
instance Package pkg => Monoid (PackageIndex pkg) where
  mempty  = PackageIndex (Map.empty)
104
105
106
107
108
  mappend = merge
  --save one mappend with empty in the common case:
  mconcat [] = mempty
  mconcat xs = foldr1 mappend xs

109
110
invariant :: Package pkg => PackageIndex pkg -> Bool
invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)
111
112
113
  where goodBucket name pkgs =
             lowercase name == name
          && not (null pkgs)
114
          && all ((lowercase name==) . lowercase . pkgName . packageId) pkgs
115
--          && all (\pkg -> pkgInfoId pkg
116
117
--                       == (packageId . packageDescription . pkgDesc) pkg) pkgs
          && distinct (map packageId pkgs)
118
119
120
121

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

internalError :: String -> a
122
internalError name = error ("PackageIndex." ++ name ++ ": internal error")
123
124
125
126

-- | When building or merging we have to eliminate duplicates of the exact
-- same package name and version (case-sensitively) to preserve the invariant.
--
127
128
stripDups :: Package pkg => [pkg] -> [pkg]
stripDups = nubBy (equating packageId)
129
130
131
132

-- | Lookup a name in the index to get all packages that match that name
-- case-insensitively.
--
133
134
lookup :: Package pkg => PackageIndex pkg -> String -> [pkg]
lookup index@(PackageIndex m) name =
135
136
137
138
139
  assert (invariant index) $
  case Map.lookup (lowercase name) m of
    Nothing   -> []
    Just pkgs -> pkgs

140
-- | Build an index out of a bunch of 'Package's.
141
142
143
--
-- If there are duplicates, earlier ones mask later one.
--
144
fromList :: Package pkg => [pkg] -> PackageIndex pkg
145
fromList pkgs =
146
147
  let index = (PackageIndex . Map.map stripDups . Map.fromListWith (++))
                [ let key = (lowercase . pkgName . packageId) pkg
148
149
150
151
152
153
154
155
156
                   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.
--
157
158
merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg
merge i1@(PackageIndex m1) i2@(PackageIndex m2) =
159
  assert (invariant i1 && invariant i2) $
160
  let index = PackageIndex (Map.unionWith mergeBuckets m1 m2)
161
162
163
164
165
166
   in assert (invariant index) index

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

-- | Get all the packages from the index.
--
167
168
allPackages :: Package pkg => PackageIndex pkg -> [pkg]
allPackages (PackageIndex m) = concat (Map.elems m)
169
170
171
172
173

-- | Get all the packages from the index.
--
-- They are grouped by package name, case-sensitively.
--
174
175
176
177
178
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))
179
180
181
182
183
184
185
186
187
188
189
190
191

-- | 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.
--
192
searchByName :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg]
193
searchByName index name =
194
195
  case groupBy (equating  (pkgName . packageId))
     . sortBy  (comparing (pkgName . packageId))
196
197
198
     $ lookup index name of
    []     -> None
    [pkgs] -> Unambiguous pkgs
199
    pkgss  -> case find ((name==) . pkgName . packageId . head) pkgss of
200
201
202
203
204
205
206
207
208
                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.
--
209
210
searchByNameSubstring :: Package pkg => PackageIndex pkg -> String -> [pkg]
searchByNameSubstring (PackageIndex m) searchterm =
211
212
213
214
215
216
217
218
219
220
221
  [ 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.
--
222
lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg
223
224
lookupPackageId index pkgid =
  case [ pkg | pkg <- lookup index (pkgName pkgid)
225
             , packageId pkg == pkgid ] of
226
227
228
229
230
231
232
233
234
    []    -> 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.
--
235
lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg]
236
lookupDependency index (Dependency name versionRange) =
237
238
  [ pkg | pkg <- lookup index name
        , let pkgid = packageId pkg
239
240
        , pkgName pkgid == name
        , pkgVersion pkgid `withinRange` versionRange ]
241
242
243
244
245

-- | All packages that have depends that are not in the index.
--
-- Returns such packages along with the depends that they're missing.
--
246
brokenPackages :: PackageIndex InstalledPackageInfo
247
248
249
250
               -> [(InstalledPackageInfo, [PackageIdentifier])]
brokenPackages index =
  [ (pkg, missing)
  | pkg  <- allPackages index
251
  , let missing = [ pkg' | pkg' <- InstalledPackageInfo.depends pkg
252
253
254
255
256
257
258
259
260
261
262
                         , 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.
--
263
dependencyClosure :: PackageIndex InstalledPackageInfo
264
                  -> [PackageIdentifier]
265
                  -> Either (PackageIndex InstalledPackageInfo)
266
267
268
269
270
271
272
273
274
275
276
277
278
279
                            [(InstalledPackageInfo, [PackageIdentifier])]
dependencyClosure index pkgids0 = case closure [] [] pkgids0 of
  (completed, []) -> Left  $ fromList completed
  (completed, _)  -> Right $ brokenPackages (fromList completed)

  where
    closure :: [InstalledPackageInfo]
            -> [PackageIdentifier]
            -> [PackageIdentifier]
            -> ([InstalledPackageInfo], [PackageIdentifier])
    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:
280
      Just pkg | packageId pkg `elem` map packageId completed
281
282
               -> closure      completed   failed  pkgids
               | otherwise
283
284
               -> closure (pkg:completed)  failed  pkgids'
               where pkgids' = InstalledPackageInfo.depends pkg ++ pkgids
285
286
287
288
289
290
291
292
293
294
295

-- | 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.
--
296
dependencyInconsistencies :: PackageIndex InstalledPackageInfo
297
298
299
300
301
302
303
304
305
                          -> PackageIdentifier -> [PackageIdentifier]
                          -> [(String, [(PackageIdentifier, Version)])]
dependencyInconsistencies index topPkg topDeps =
  [ (name, inconsistencies)
  | (name, uses) <- Map.toList inverseIndex
  , let inconsistencies = duplicatesBy uses
  , not (null inconsistencies) ]

  where pseudoTopPackage = emptyInstalledPackageInfo {
306
307
          InstalledPackageInfo.package = topPkg,
          InstalledPackageInfo.depends = topDeps
308
309
        }
        inverseIndex = Map.fromListWith (++)
310
          [ (pkgName dep, [(InstalledPackageInfo.package pkg, pkgVersion dep)])
311
          | pkg <- pseudoTopPackage : allPackages index
312
          , dep <- InstalledPackageInfo.depends pkg ]
313
314
315
316
317
318

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