blob: f1e02773e3ddcc0582af723a2410424520311b14 (
plain)
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
183
184
185
186
187
188
189
190
|
(define-module (pypi sdist-store)
#:use-module (logging logger)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (ice-9 hash-table)
#:use-module (ice-9 pretty-print)
#:use-module (guix ui)
#:use-module (guix packages)
#:use-module (guix build utils)
#:use-module (guix download)
#:use-module (pypi sdist)
#:use-module (pypi version)
#:use-module (pypi requirement)
#:export (make-sdist-store
add-sdist
add-sdists
get-sdist
get-sdists
get-sdist-list
get-sdists-by-version-meeting-requirement
get-sdist-best-matching-requirement
get-sdist-best-matching-requirements
store-can-satisfy-requirement?
log-sdist-store
create-sdists-module))
(define (vhash-set key value vhash)
(vhash-cons
key
value
(vhash-delete
key
vhash)))
(define (make-sdist-store)
vlist-null)
(define (add-sdist store sd)
(let*
((info (sdist-info sd))
(name (normalise-requirement-name (pkg-info-name info)))
(version (pkg-info-version info))
(versions
(vhash-assoc
(normalise-requirement-name name)
store)))
(vhash-set
name
(vhash-set
version
sd
(if versions
(cdr versions)
vlist-null))
store)))
(define (log-sdist-store level sdist-store)
(for-each
(match-lambda
((name . versions)
(log-msg level name ":")
(for-each
(match-lambda
((version . sdist)
(log-msg level " " version)))
(vlist->list versions))))
(vlist->list sdist-store)))
(define (add-sdists store sds)
(fold
(lambda (sd store)
(add-sdist store sd))
store
sds))
(define (get-sdists store name) ; TODO: Change this, as it does not get sdists (instead it gets an alist)
(let
((p
(vhash-assoc (normalise-requirement-name name) store)))
(if p
(vlist->list (cdr p))
'())))
(define (get-sdists-by-version-meeting-requirement sdist-store requirement)
(filter
(match-lambda
((version . sd)
(sdist-meets-requirement sd requirement)))
(get-sdists sdist-store (requirement-name requirement))))
(define (get-sdist store name version)
(assoc-ref
(get-sdists store name)
version))
(define (sort-version-alist al)
(let*
((versions (map car al))
(sorted-versions (sort-versions versions)))
(map
(lambda (version)
(cons version (assoc-ref al version)))
sorted-versions)))
(define (get-sdist-list store)
(apply
append
(map
cdr
(stable-sort
(vlist->list
(vlist-map
(match-lambda
((name . versions)
(cons
name
(map cdr
(sort-version-alist
(vlist->list versions))))))
store))
(lambda (x y)
(string<? (car x) (car y)))))))
(define (create-sdists-module store module path)
(call-with-output-file
path
(lambda (port)
(pretty-print
`(define-module ,module
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build utils)
#:use-module (pypi sdist)
#:use-module (pypi requirement))
port)
(pretty-print
`(define-public
sdists
,(append
'(list)
(map get-quoted-sdist (get-sdist-list store))))
port))))
(define (store-can-satisfy-requirement? store r)
(get-sdist-best-matching-requirement store r))
(define (get-sdist-best-matching-requirement store r)
(get-sdist-best-matching-requirements store (list r)))
(define (get-sdist-best-matching-requirements store requirements)
(let*
((unique-names
(apply
lset-adjoin
(append
(list equal? '())
(map (lambda (r) (normalise-requirement-name
(requirement-name r)))
requirements))))
(normalised-name (first unique-names)))
(if (not (eq? 1 (length unique-names)))
(error "Not all requirements are for the name package"
requirements))
(let ((sorted-suitable-versions
(let*
((sdists (filter
(lambda (sd)
(every
(lambda (r)
(sdist-meets-requirement sd r))
requirements))
(map cdr (get-sdists store normalised-name))))
(sdists-and-versions
(map
(lambda (sd) (cons (pkg-info-version (sdist-info sd)) sd))
sdists))
(sorted-versions
(sort-versions (map car sdists-and-versions))))
(map
(lambda (v) (assoc-ref sdists-and-versions v))
sorted-versions))))
(if (> (length sorted-suitable-versions) 0)
(first sorted-suitable-versions)
#f))))
|