LookupSet.curry 6.39 KB
Newer Older
Michael Hanus's avatar
Michael Hanus committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
------------------------------------------------------------------------------
--- This module implements the LookupSet datatype. A lookup set is used to store
--- and query packages for dependency resolution. It stores the source of a 
--- package specification alongside the specification itself (e.g. the global
--- repository or the local package cache).
------------------------------------------------------------------------------

module CPM.LookupSet 
  ( LookupSource (..)
  , LookupSet
  , emptySet
  , addPackage
  , findLatestVersion
  , findAllVersions
  , findVersion
  , addPackages
  , allPackages
  , lookupSource
  , setLocallyIgnored
  ) where

import List (sortBy, delete, deleteBy)
import Test.EasyCheck

Michael Hanus's avatar
Michael Hanus committed
25
26
import Data.Table.RBTree as Table ( TableRBT, empty, lookup, toList,update )

Michael Hanus's avatar
Michael Hanus committed
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
import CPM.Package 

------------------------------------------------------------------------------

data LookupSource = FromRepository
                  | FromLocalCache
                  | FromGlobalCache

type PkgMap = TableRBT String [(LookupSource, Package)]

data LookupSet = LookupSet PkgMap LookupOptions

data LookupOptions = LookupOptions
  { ignoreLocalVersions :: [String] }

--- The empty lookup set.
emptySet :: LookupSet
Michael Hanus's avatar
Michael Hanus committed
44
emptySet = LookupSet (empty (<=)) defaultOptions
Michael Hanus's avatar
Michael Hanus committed
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63

defaultOptions :: LookupOptions
defaultOptions = LookupOptions []

--- Set the set of packages whose locally installed versions are ignored when
--- finding all package versions. 
setLocallyIgnored :: LookupSet -> [String] -> LookupSet
setLocallyIgnored (LookupSet ls o) pkgs = 
  LookupSet ls (o { ignoreLocalVersions = pkgs })

--- Adds multiple packages to a lookup set with the same source.
---
--- @param l the set to add to
--- @param p the packages to add
--- @param s where are the package specs from?
addPackages :: LookupSet -> [Package] -> LookupSource -> LookupSet
addPackages ls pkgs src = foldl (\l p -> addPackage l p src) ls pkgs

allPackages :: LookupSet -> [Package]
Michael Hanus's avatar
Michael Hanus committed
64
allPackages (LookupSet ls _) = map snd $ concat $ map snd $ toList ls
Michael Hanus's avatar
Michael Hanus committed
65
66
67
68
69
70
71

--- Adds a package to a lookup set.
---
--- @param l the set to add to
--- @param p the package to add
--- @param s where is the package spec from?
addPackage :: LookupSet -> Package -> LookupSource -> LookupSet
Michael Hanus's avatar
Michael Hanus committed
72
73
addPackage (LookupSet ls o) pkg src = case Table.lookup (name pkg) ls of
  Nothing -> LookupSet (update (name pkg) [(src, pkg)] ls) o
Michael Hanus's avatar
Michael Hanus committed
74
  Just ps -> let ps' = filter ((/= packageId pkg) . packageId . snd) ps
Michael Hanus's avatar
Michael Hanus committed
75
              in LookupSet (update (name pkg) ((src, pkg):ps') ls) o 
Michael Hanus's avatar
Michael Hanus committed
76
77
78
79
80
81
82
83

--- Finds a specific entry (including the source) in the lookup set.
---
--- @param l the lookup set
--- @param p the package to search for
findEntry :: LookupSet -> Package -> Maybe (LookupSource, Package)
findEntry (LookupSet ls _) p = maybeHead candidates
 where
Michael Hanus's avatar
Michael Hanus committed
84
  allVersions = Table.lookup (name p) ls
Michael Hanus's avatar
Michael Hanus committed
85
86
87
88
89
90
91
92
93
94
95
96
97
98
  candidates = case allVersions of
    Nothing -> []
    Just ps -> filter ((packageIdEq p) . snd) ps

--- Finds all versions of a package known to the lookup set. Returns the 
--- packages from the local cache first, and then from other sources. Each
--- group is sorted from newest do oldest version.
---
--- @param l the lookup set
--- @param p the name of the package to search for
--- @param pre should pre-release versions be included?
findAllVersions :: LookupSet -> String -> Bool -> [Package]
findAllVersions (LookupSet ls o) p pre = localSorted' ++ nonLocalSorted
  where 
Michael Hanus's avatar
Michael Hanus committed
99
    packageVersions = case Table.lookup p ls of
Michael Hanus's avatar
Michael Hanus committed
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
      Nothing -> []
      Just vs -> vs
    onlyLocal = filter isLocal packageVersions
    onlyNonLocal = filter (not . isLocal) packageVersions
    localSorted = sortedByVersion $ preFiltered $ sameName $ ps $ onlyLocal
    localSorted' = filter (not . (flip elem) (ignoreLocalVersions o) . name) localSorted
    nonLocalSorted = sortedByVersion $ preFiltered $ sameName $ ps $ onlyNonLocal
    sortedByVersion = sortBy (\a b -> (version a) `vgt` (version b))
    preFiltered = filter filterPre
    sameName = filter ((== p) . name) 
    filterPre p' = pre || (not . isPreRelease . version) p'
    isLocal (FromLocalCache, _) = True
    isLocal (FromGlobalCache, _) = False
    isLocal (FromRepository, _) = False
    ps = map snd 

test_findAllVersions_localBeforeNonLocal :: Test.EasyCheck.Prop
test_findAllVersions_localBeforeNonLocal = findAllVersions ls "A" False -=- [aLocal, aNonLocal]
  where aLocal = cPackage "A" (1, 0, 0, Nothing) []
        aNonLocal = cPackage "A" (1, 1, 0, Nothing) []
        ls = addPackage (addPackage emptySet aLocal FromLocalCache) aNonLocal FromRepository

test_findAllVersions_nonLocalIfIgnored :: Test.EasyCheck.Prop
test_findAllVersions_nonLocalIfIgnored = findAllVersions ls "A" False -=- [aNonLocal]
  where aLocal = cPackage "A" (1, 0, 0, Nothing) []
        aNonLocal = cPackage "A" (1, 1, 0, Nothing) []
        ls = setLocallyIgnored (addPackage (addPackage emptySet aLocal FromLocalCache) aNonLocal FromRepository) ["A"]

cPackage :: String -> Version -> [Dependency] -> Package
cPackage p v ds = emptyPackage {
    name = p
  , version = v
  , author = "author"
  , synopsis = "JSON library for Curry"
  , dependencies = ds
  , maintainer = Nothing
  , description = Nothing
  , license = Nothing
  , licenseFile = Nothing
  , copyright = Nothing
  , homepage = Nothing
  , bugReports = Nothing
  , repository = Nothing
  , compilerCompatibility = []
  , source = Nothing
  , exportedModules = []
  }

cDB :: [Package] -> LookupSet
cDB ps = addPackages emptySet ps FromRepository

--- Finds the source for a package in the lookup set
---
--- @param ls the lookup set
--- @param p the package to search for
lookupSource :: LookupSet -> Package -> Maybe LookupSource
lookupSource ls p = case findEntry ls p of
  Nothing     -> Nothing
  Just (s, _) -> Just s

--- Finds the latest version of a package known to the lookup set.
---
--- @param l the lookup set
--- @param p the name of the package to search for
--- @param pre should pre-release versions be included?
findLatestVersion :: LookupSet -> String -> Bool -> Maybe Package
findLatestVersion ls p pre = case findAllVersions ls p pre of
  [] -> Nothing
  (x:_) -> Just x

--- Finds a specific version of a package in the lookup set.
---
--- @param l the lookup set
--- @param p the name of the package
--- @param v the package version
findVersion :: LookupSet -> String -> Version -> Maybe Package
176
177
findVersion ls p v =
  maybeHead $ filter ((== v) . version) $ findAllVersions ls p True
Michael Hanus's avatar
Michael Hanus committed
178
179
180
181

maybeHead :: [a] -> Maybe a
maybeHead []    = Nothing
maybeHead (x:_) = Just x