1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
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
176
177
178
179
180
181
182

------------------------------------------------------------------------------
--- 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 Data.List (sortBy, delete, deleteBy)
import Test.Prop
import Prelude hiding (empty)

import Data.Table.RBTree as Table ( TableRBT, empty, lookup, toList,update )

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
emptySet = LookupSet (empty (<=)) defaultOptions

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]
allPackages (LookupSet ls _) = map snd $ concat $ map snd $ toList ls

--- 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
addPackage (LookupSet ls o) pkg src = case Table.lookup (name pkg) ls of
  Nothing -> LookupSet (update (name pkg) [(src, pkg)] ls) o
  Just ps -> let ps' = filter ((/= packageId pkg) . packageId . snd) ps
              in LookupSet (update (name pkg) ((src, pkg):ps') ls) o

--- 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
  allVersions = Table.lookup (name p) ls
  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
    packageVersions = case Table.lookup p ls of
      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 :: 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 :: 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 = []
  , 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
findVersion ls p v =
  maybeHead $ filter ((== v) . version) $ findAllVersions ls p True

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