Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
f9704f17 | 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> |
c2868b1e | 3 | ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> |
7d193ec3 | 4 | ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> |
6caa4dfa | 5 | ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> |
fad155d4 | 6 | ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> |
6b1891b0 | 7 | ;;; |
233e7676 | 8 | ;;; This file is part of GNU Guix. |
6b1891b0 | 9 | ;;; |
233e7676 | 10 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
6b1891b0 LC |
11 | ;;; under the terms of the GNU General Public License as published by |
12 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
13 | ;;; your option) any later version. | |
14 | ;;; | |
233e7676 | 15 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
6b1891b0 LC |
16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
19 | ;;; | |
20 | ;;; You should have received a copy of the GNU General Public License | |
233e7676 | 21 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
6b1891b0 | 22 | |
59a43334 | 23 | (define-module (gnu packages) |
6b1891b0 | 24 | #:use-module (guix packages) |
98eb8cbe | 25 | #:use-module (guix ui) |
800cdeef | 26 | #:use-module (guix utils) |
f9704f17 | 27 | #:use-module (guix memoization) |
958dd3ce | 28 | #:use-module (guix combinators) |
95cd4971 LC |
29 | #:use-module ((guix build utils) |
30 | #:select ((package-name->name+version | |
31 | . hyphen-separated-name->name+version))) | |
6b1891b0 | 32 | #:use-module (ice-9 ftw) |
c2868b1e | 33 | #:use-module (ice-9 vlist) |
dc5669cd | 34 | #:use-module (ice-9 match) |
6b1891b0 | 35 | #:use-module (srfi srfi-1) |
5e3b388b | 36 | #:use-module (srfi srfi-11) |
6b1891b0 | 37 | #:use-module (srfi srfi-26) |
dbab5150 LC |
38 | #:use-module (srfi srfi-34) |
39 | #:use-module (srfi srfi-35) | |
800cdeef LC |
40 | #:use-module (srfi srfi-39) |
41 | #:export (search-patch | |
25897079 | 42 | search-patches |
ac5aa288 | 43 | search-bootstrap-binary |
0492f4a2 | 44 | %patch-path |
0b3651bc | 45 | %bootstrap-binaries-path |
c107b541 | 46 | %package-module-path |
7d193ec3 | 47 | |
ba326ce4 | 48 | fold-packages |
2a6ba870 | 49 | scheme-modules ;XXX: for lack of a better place |
7d193ec3 | 50 | |
dc5669cd | 51 | find-packages-by-name |
3f26bfc1 | 52 | find-best-packages-by-name |
7d193ec3 EB |
53 | find-newest-available-packages |
54 | ||
84189ebc LC |
55 | specification->package |
56 | specification->package+output)) | |
6b1891b0 LC |
57 | |
58 | ;;; Commentary: | |
59 | ;;; | |
60 | ;;; General utilities for the software distribution---i.e., the modules under | |
59a43334 | 61 | ;;; (gnu packages ...). |
6b1891b0 LC |
62 | ;;; |
63 | ;;; Code: | |
64 | ||
0b3651bc LC |
65 | ;; By default, we store patches and bootstrap binaries alongside Guile |
66 | ;; modules. This is so that these extra files can be found without | |
67 | ;; requiring a special setup, such as a specific installation directory | |
68 | ;; and an extra environment variable. One advantage of this setup is | |
69 | ;; that everything just works in an auto-compilation setting. | |
a9f60c42 | 70 | |
a9f60c42 | 71 | (define %bootstrap-binaries-path |
ac5aa288 | 72 | (make-parameter |
1ffa7090 | 73 | (map (cut string-append <> "/gnu/packages/bootstrap") |
0b3651bc | 74 | %load-path))) |
ac5aa288 | 75 | |
800cdeef | 76 | (define (search-patch file-name) |
dbab5150 LC |
77 | "Search the patch FILE-NAME. Raise an error if not found." |
78 | (or (search-path (%patch-path) file-name) | |
79 | (raise (condition | |
80 | (&message (message (format #f (_ "~a: patch not found") | |
81 | file-name))))))) | |
800cdeef | 82 | |
25897079 AK |
83 | (define-syntax-rule (search-patches file-name ...) |
84 | "Return the list of absolute file names corresponding to each | |
85 | FILE-NAME found in %PATCH-PATH." | |
86 | (list (search-patch file-name) ...)) | |
87 | ||
ac5aa288 | 88 | (define (search-bootstrap-binary file-name system) |
dfba5489 LC |
89 | "Search the bootstrap binary FILE-NAME for SYSTEM. Raise an error if not |
90 | found." | |
91 | (or (search-path (%bootstrap-binaries-path) | |
92 | (string-append system "/" file-name)) | |
93 | (raise (condition | |
94 | (&message | |
95 | (message | |
96 | (format #f (_ "could not find bootstrap binary '~a' \ | |
97 | for system '~a'") | |
98 | file-name system))))))) | |
ac5aa288 | 99 | |
84836a57 LC |
100 | (define %distro-root-directory |
101 | ;; Absolute file name of the module hierarchy. | |
102 | (dirname (search-path %load-path "guix.scm"))) | |
6b1891b0 | 103 | |
c107b541 LC |
104 | (define %package-module-path |
105 | ;; Search path for package modules. Each item must be either a directory | |
106 | ;; name or a pair whose car is a directory and whose cdr is a sub-directory | |
107 | ;; to narrow the search. | |
8689901f LC |
108 | (let* ((not-colon (char-set-complement (char-set #\:))) |
109 | (environment (string-tokenize (or (getenv "GUIX_PACKAGE_PATH") "") | |
110 | not-colon))) | |
111 | ;; Automatically add items from $GUIX_PACKAGE_PATH to Guile's search path. | |
112 | (for-each (lambda (directory) | |
113 | (set! %load-path (cons directory %load-path)) | |
114 | (set! %load-compiled-path | |
115 | (cons directory %load-compiled-path))) | |
116 | environment) | |
117 | ||
118 | (make-parameter | |
119 | (append environment `((,%distro-root-directory . "gnu/packages")))))) | |
c107b541 | 120 | |
ee06af5b LC |
121 | (define %patch-path |
122 | ;; Define it after '%package-module-path' so that '%load-path' contains user | |
123 | ;; directories, allowing patches in $GUIX_PACKAGE_PATH to be found. | |
124 | (make-parameter | |
125 | (map (lambda (directory) | |
126 | (if (string=? directory %distro-root-directory) | |
127 | (string-append directory "/gnu/packages/patches") | |
128 | directory)) | |
129 | %load-path))) | |
130 | ||
84836a57 | 131 | (define* (scheme-files directory) |
d95523fb LC |
132 | "Return the list of Scheme files found under DIRECTORY, recursively. The |
133 | returned list is sorted in alphabetical order." | |
134 | ||
135 | ;; Sort entries so that 'fold-packages' works in a deterministic fashion | |
136 | ;; regardless of details of the underlying file system. | |
137 | (sort (file-system-fold (const #t) ; enter? | |
138 | (lambda (path stat result) ; leaf | |
139 | (if (string-suffix? ".scm" path) | |
140 | (cons path result) | |
141 | result)) | |
142 | (lambda (path stat result) ; down | |
143 | result) | |
144 | (lambda (path stat result) ; up | |
145 | result) | |
146 | (const #f) ; skip | |
147 | (lambda (path stat errno result) | |
148 | (warning (_ "cannot access `~a': ~a~%") | |
149 | path (strerror errno)) | |
150 | result) | |
151 | '() | |
152 | directory | |
153 | stat) | |
154 | string<?)) | |
6b1891b0 | 155 | |
c107b541 LC |
156 | (define file-name->module-name |
157 | (let ((not-slash (char-set-complement (char-set #\/)))) | |
158 | (lambda (file) | |
159 | "Return the module name (a list of symbols) corresponding to FILE." | |
160 | (map string->symbol | |
161 | (string-tokenize (string-drop-right file 4) not-slash))))) | |
84836a57 | 162 | |
2a6ba870 LC |
163 | (define* (scheme-modules directory #:optional sub-directory) |
164 | "Return the list of Scheme modules available under DIRECTORY. | |
84836a57 LC |
165 | Optionally, narrow the search to SUB-DIRECTORY." |
166 | (define prefix-len | |
167 | (string-length directory)) | |
168 | ||
169 | (filter-map (lambda (file) | |
4ae7559f LC |
170 | (let* ((file (substring file prefix-len)) |
171 | (module (file-name->module-name file))) | |
172 | (catch #t | |
173 | (lambda () | |
174 | (resolve-interface module)) | |
175 | (lambda args | |
176 | ;; Report the error, but keep going. | |
177 | (warn-about-load-error module args) | |
178 | #f)))) | |
84836a57 LC |
179 | (scheme-files (if sub-directory |
180 | (string-append directory "/" sub-directory) | |
181 | directory)))) | |
6b1891b0 | 182 | |
c107b541 LC |
183 | (define* (all-package-modules #:optional (path (%package-module-path))) |
184 | "Return the list of package modules found in PATH, a list of directories to | |
185 | search." | |
186 | (fold-right (lambda (spec result) | |
187 | (match spec | |
188 | ((? string? directory) | |
2a6ba870 | 189 | (append (scheme-modules directory) result)) |
c107b541 | 190 | ((directory . sub-directory) |
2a6ba870 | 191 | (append (scheme-modules directory sub-directory) |
c107b541 LC |
192 | result)))) |
193 | '() | |
194 | path)) | |
195 | ||
ba326ce4 LC |
196 | (define (fold-packages proc init) |
197 | "Call (PROC PACKAGE RESULT) for each available package, using INIT as | |
c2868b1e MW |
198 | the initial value of RESULT. It is guaranteed to never traverse the |
199 | same package twice." | |
200 | (identity ; discard second return value | |
201 | (fold2 (lambda (module result seen) | |
202 | (fold2 (lambda (var result seen) | |
203 | (if (and (package? var) | |
6980511b LC |
204 | (not (vhash-assq var seen)) |
205 | (not (hidden-package? var))) | |
c2868b1e MW |
206 | (values (proc var result) |
207 | (vhash-consq var #t seen)) | |
208 | (values result seen))) | |
209 | result | |
210 | seen | |
211 | (module-map (lambda (sym var) | |
212 | (false-if-exception (variable-ref var))) | |
213 | module))) | |
214 | init | |
215 | vlist-null | |
c107b541 | 216 | (all-package-modules)))) |
ba326ce4 | 217 | |
9ffc1c00 LC |
218 | (define find-packages-by-name |
219 | (let ((packages (delay | |
220 | (fold-packages (lambda (p r) | |
221 | (vhash-cons (package-name p) p r)) | |
724311a2 LC |
222 | vlist-null))) |
223 | (version>? (lambda (p1 p2) | |
224 | (version>? (package-version p1) (package-version p2))))) | |
9ffc1c00 LC |
225 | (lambda* (name #:optional version) |
226 | "Return the list of packages with the given NAME. If VERSION is not #f, | |
724311a2 LC |
227 | then only return packages whose version is prefixed by VERSION, sorted in |
228 | decreasing version order." | |
229 | (let ((matching (sort (vhash-fold* cons '() name (force packages)) | |
230 | version>?))) | |
9ffc1c00 LC |
231 | (if version |
232 | (filter (lambda (package) | |
724311a2 | 233 | (string-prefix? version (package-version package))) |
9ffc1c00 LC |
234 | matching) |
235 | matching))))) | |
dc5669cd | 236 | |
3f26bfc1 | 237 | (define find-newest-available-packages |
55b2d921 LC |
238 | (mlambda () |
239 | "Return a vhash keyed by package names, and with | |
dc5669cd MW |
240 | associated values of the form |
241 | ||
242 | (newest-version newest-package ...) | |
243 | ||
244 | where the preferred package is listed first." | |
245 | ||
55b2d921 LC |
246 | ;; FIXME: Currently, the preferred package is whichever one |
247 | ;; was found last by 'fold-packages'. Find a better solution. | |
248 | (fold-packages (lambda (p r) | |
249 | (let ((name (package-name p)) | |
250 | (version (package-version p))) | |
251 | (match (vhash-assoc name r) | |
252 | ((_ newest-so-far . pkgs) | |
253 | (case (version-compare version newest-so-far) | |
254 | ((>) (vhash-cons name `(,version ,p) r)) | |
255 | ((=) (vhash-cons name `(,version ,p ,@pkgs) r)) | |
256 | ((<) r))) | |
257 | (#f (vhash-cons name `(,version ,p) r))))) | |
258 | vlist-null))) | |
3f26bfc1 LC |
259 | |
260 | (define (find-best-packages-by-name name version) | |
261 | "If version is #f, return the list of packages named NAME with the highest | |
262 | version numbers; otherwise, return the list of packages named NAME and at | |
263 | VERSION." | |
264 | (if version | |
265 | (find-packages-by-name name version) | |
266 | (match (vhash-assoc name (find-newest-available-packages)) | |
267 | ((_ version pkgs ...) pkgs) | |
268 | (#f '())))) | |
7d193ec3 EB |
269 | |
270 | \f | |
4ea44419 AK |
271 | (define %sigint-prompt |
272 | ;; The prompt to jump to upon SIGINT. | |
273 | (make-prompt-tag "interruptible")) | |
274 | ||
275 | (define (call-with-sigint-handler thunk handler) | |
276 | "Call THUNK and return its value. Upon SIGINT, call HANDLER with the signal | |
277 | number in the context of the continuation of the call to this function, and | |
278 | return its return value." | |
279 | (call-with-prompt %sigint-prompt | |
280 | (lambda () | |
281 | (sigaction SIGINT | |
282 | (lambda (signum) | |
283 | (sigaction SIGINT SIG_DFL) | |
284 | (abort-to-prompt %sigint-prompt signum))) | |
285 | (dynamic-wind | |
286 | (const #t) | |
287 | thunk | |
288 | (cut sigaction SIGINT SIG_DFL))) | |
289 | (lambda (k signum) | |
290 | (handler signum)))) | |
291 | ||
fad155d4 ML |
292 | \f |
293 | ;;; | |
294 | ;;; Package specification. | |
295 | ;;; | |
296 | ||
1b846da8 | 297 | (define* (%find-package spec name version #:key fallback?) |
fad155d4 ML |
298 | (match (find-best-packages-by-name name version) |
299 | ((pkg . pkg*) | |
300 | (unless (null? pkg*) | |
301 | (warning (_ "ambiguous package specification `~a'~%") spec) | |
302 | (warning (_ "choosing ~a from ~a~%") | |
303 | (package-full-name pkg) | |
304 | (location->string (package-location pkg)))) | |
1b846da8 | 305 | (when fallback? |
7befee30 LC |
306 | (warning (_ "deprecated NAME-VERSION syntax; \ |
307 | use NAME@VERSION instead~%"))) | |
01afdab8 LC |
308 | |
309 | (match (package-superseded pkg) | |
310 | ((? package? new) | |
311 | (info (_ "package '~a' has been superseded by '~a'~%") | |
312 | (package-name pkg) (package-name new)) | |
313 | new) | |
314 | (#f | |
315 | pkg))) | |
e465d9e1 | 316 | (x |
fad155d4 ML |
317 | (if version |
318 | (leave (_ "~A: package not found for version ~a~%") name version) | |
efb107e0 | 319 | (if (not fallback?) |
1b846da8 ML |
320 | ;; XXX: Fallback to the older specification style with an hyphen |
321 | ;; between NAME and VERSION, for backward compatibility. | |
95cd4971 LC |
322 | (call-with-values |
323 | (lambda () | |
324 | (hyphen-separated-name->name+version name)) | |
325 | (cut %find-package spec <> <> #:fallback? #t)) | |
efb107e0 LC |
326 | |
327 | ;; The fallback case didn't find anything either, so bail out. | |
1b846da8 | 328 | (leave (_ "~A: unknown package~%") name)))))) |
fad155d4 | 329 | |
5e3b388b CR |
330 | (define (specification->package spec) |
331 | "Return a package matching SPEC. SPEC may be a package name, or a package | |
1b846da8 | 332 | name followed by an at-sign and a version number. If the version number is not |
5e3b388b | 333 | present, return the preferred newest version." |
fad155d4 ML |
334 | (let-values (((name version) (package-name->name+version spec))) |
335 | (%find-package spec name version))) | |
84189ebc LC |
336 | |
337 | (define* (specification->package+output spec #:optional (output "out")) | |
338 | "Return the package and output specified by SPEC, or #f and #f; SPEC may | |
339 | optionally contain a version number and an output name, as in these examples: | |
340 | ||
341 | guile | |
1b846da8 | 342 | guile@2.0.9 |
84189ebc | 343 | guile:debug |
1b846da8 | 344 | guile@2.0.9:debug |
84189ebc LC |
345 | |
346 | If SPEC does not specify a version number, return the preferred newest | |
347 | version; if SPEC does not specify an output, return OUTPUT." | |
84189ebc LC |
348 | (let-values (((name version sub-drv) |
349 | (package-specification->name+version+output spec output))) | |
fad155d4 ML |
350 | (match (%find-package spec name version) |
351 | (#f | |
352 | (values #f #f)) | |
353 | (package | |
354 | (if (member sub-drv (package-outputs package)) | |
355 | (values package sub-drv) | |
356 | (leave (_ "package `~a' lacks output `~a'~%") | |
357 | (package-full-name package) | |
358 | sub-drv)))))) |