Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
1ffa7090 | 2 | ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> |
c2868b1e | 3 | ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> |
6b1891b0 | 4 | ;;; |
233e7676 | 5 | ;;; This file is part of GNU Guix. |
6b1891b0 | 6 | ;;; |
233e7676 | 7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
6b1891b0 LC |
8 | ;;; under the terms of the GNU General Public License as published by |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
233e7676 | 12 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
6b1891b0 LC |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
233e7676 | 18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
6b1891b0 | 19 | |
59a43334 | 20 | (define-module (gnu packages) |
6b1891b0 | 21 | #:use-module (guix packages) |
98eb8cbe | 22 | #:use-module (guix ui) |
800cdeef | 23 | #:use-module (guix utils) |
6b1891b0 | 24 | #:use-module (ice-9 ftw) |
c2868b1e | 25 | #:use-module (ice-9 vlist) |
dc5669cd | 26 | #:use-module (ice-9 match) |
6b1891b0 LC |
27 | #:use-module (srfi srfi-1) |
28 | #:use-module (srfi srfi-26) | |
800cdeef LC |
29 | #:use-module (srfi srfi-39) |
30 | #:export (search-patch | |
ac5aa288 | 31 | search-bootstrap-binary |
800cdeef | 32 | %patch-directory |
0b3651bc | 33 | %bootstrap-binaries-path |
ba326ce4 | 34 | fold-packages |
dc5669cd | 35 | find-packages-by-name |
3f26bfc1 | 36 | find-best-packages-by-name |
dc5669cd | 37 | find-newest-available-packages)) |
6b1891b0 LC |
38 | |
39 | ;;; Commentary: | |
40 | ;;; | |
41 | ;;; General utilities for the software distribution---i.e., the modules under | |
59a43334 | 42 | ;;; (gnu packages ...). |
6b1891b0 LC |
43 | ;;; |
44 | ;;; Code: | |
45 | ||
46 | (define _ (cut gettext <> "guix")) | |
47 | ||
0b3651bc LC |
48 | ;; By default, we store patches and bootstrap binaries alongside Guile |
49 | ;; modules. This is so that these extra files can be found without | |
50 | ;; requiring a special setup, such as a specific installation directory | |
51 | ;; and an extra environment variable. One advantage of this setup is | |
52 | ;; that everything just works in an auto-compilation setting. | |
a9f60c42 LC |
53 | |
54 | (define %patch-path | |
800cdeef | 55 | (make-parameter |
1ffa7090 | 56 | (map (cut string-append <> "/gnu/packages/patches") |
0b3651bc | 57 | %load-path))) |
800cdeef | 58 | |
a9f60c42 | 59 | (define %bootstrap-binaries-path |
ac5aa288 | 60 | (make-parameter |
1ffa7090 | 61 | (map (cut string-append <> "/gnu/packages/bootstrap") |
0b3651bc | 62 | %load-path))) |
ac5aa288 | 63 | |
800cdeef LC |
64 | (define (search-patch file-name) |
65 | "Search the patch FILE-NAME." | |
128663e4 | 66 | (search-path (%patch-path) file-name)) |
800cdeef | 67 | |
ac5aa288 LC |
68 | (define (search-bootstrap-binary file-name system) |
69 | "Search the bootstrap binary FILE-NAME for SYSTEM." | |
128663e4 LC |
70 | (search-path (%bootstrap-binaries-path) |
71 | (string-append system "/" file-name))) | |
ac5aa288 | 72 | |
6b1891b0 | 73 | (define %distro-module-directory |
1ffa7090 | 74 | ;; Absolute path of the (gnu packages ...) module root. |
59a43334 LC |
75 | (string-append (dirname (search-path %load-path "gnu/packages.scm")) |
76 | "/packages")) | |
6b1891b0 LC |
77 | |
78 | (define (package-files) | |
79 | "Return the list of files that implement distro modules." | |
80 | (define prefix-len | |
59a43334 LC |
81 | (string-length |
82 | (dirname (dirname (search-path %load-path "gnu/packages.scm"))))) | |
6b1891b0 LC |
83 | |
84 | (file-system-fold (const #t) ; enter? | |
85 | (lambda (path stat result) ; leaf | |
86 | (if (string-suffix? ".scm" path) | |
87 | (cons (substring path prefix-len) result) | |
88 | result)) | |
89 | (lambda (path stat result) ; down | |
90 | result) | |
91 | (lambda (path stat result) ; up | |
92 | result) | |
93 | (const #f) ; skip | |
94 | (lambda (path stat errno result) | |
98eb8cbe NK |
95 | (warning (_ "cannot access `~a': ~a~%") |
96 | path (strerror errno)) | |
6b1891b0 LC |
97 | result) |
98 | '() | |
99 | %distro-module-directory | |
100 | stat)) | |
101 | ||
102 | (define (package-modules) | |
103 | "Return the list of modules that provide packages for the distribution." | |
104 | (define not-slash | |
105 | (char-set-complement (char-set #\/))) | |
106 | ||
107 | (filter-map (lambda (path) | |
108 | (let ((name (map string->symbol | |
109 | (string-tokenize (string-drop-right path 4) | |
110 | not-slash)))) | |
111 | (false-if-exception (resolve-interface name)))) | |
112 | (package-files))) | |
113 | ||
ba326ce4 LC |
114 | (define (fold-packages proc init) |
115 | "Call (PROC PACKAGE RESULT) for each available package, using INIT as | |
c2868b1e MW |
116 | the initial value of RESULT. It is guaranteed to never traverse the |
117 | same package twice." | |
118 | (identity ; discard second return value | |
119 | (fold2 (lambda (module result seen) | |
120 | (fold2 (lambda (var result seen) | |
121 | (if (and (package? var) | |
122 | (not (vhash-assq var seen))) | |
123 | (values (proc var result) | |
124 | (vhash-consq var #t seen)) | |
125 | (values result seen))) | |
126 | result | |
127 | seen | |
128 | (module-map (lambda (sym var) | |
129 | (false-if-exception (variable-ref var))) | |
130 | module))) | |
131 | init | |
132 | vlist-null | |
133 | (package-modules)))) | |
ba326ce4 | 134 | |
6b1891b0 LC |
135 | (define* (find-packages-by-name name #:optional version) |
136 | "Return the list of packages with the given NAME. If VERSION is not #f, | |
137 | then only return packages whose version is equal to VERSION." | |
138 | (define right-package? | |
139 | (if version | |
140 | (lambda (p) | |
ba326ce4 | 141 | (and (string=? (package-name p) name) |
6b1891b0 LC |
142 | (string=? (package-version p) version))) |
143 | (lambda (p) | |
ba326ce4 LC |
144 | (string=? (package-name p) name)))) |
145 | ||
146 | (fold-packages (lambda (package result) | |
147 | (if (right-package? package) | |
148 | (cons package result) | |
149 | result)) | |
150 | '())) | |
dc5669cd | 151 | |
3f26bfc1 LC |
152 | (define find-newest-available-packages |
153 | (memoize | |
154 | (lambda () | |
155 | "Return a vhash keyed by package names, and with | |
dc5669cd MW |
156 | associated values of the form |
157 | ||
158 | (newest-version newest-package ...) | |
159 | ||
160 | where the preferred package is listed first." | |
161 | ||
3f26bfc1 LC |
162 | ;; FIXME: Currently, the preferred package is whichever one |
163 | ;; was found last by 'fold-packages'. Find a better solution. | |
164 | (fold-packages (lambda (p r) | |
165 | (let ((name (package-name p)) | |
166 | (version (package-version p))) | |
167 | (match (vhash-assoc name r) | |
168 | ((_ newest-so-far . pkgs) | |
169 | (case (version-compare version newest-so-far) | |
170 | ((>) (vhash-cons name `(,version ,p) r)) | |
171 | ((=) (vhash-cons name `(,version ,p ,@pkgs) r)) | |
172 | ((<) r))) | |
173 | (#f (vhash-cons name `(,version ,p) r))))) | |
174 | vlist-null)))) | |
175 | ||
176 | (define (find-best-packages-by-name name version) | |
177 | "If version is #f, return the list of packages named NAME with the highest | |
178 | version numbers; otherwise, return the list of packages named NAME and at | |
179 | VERSION." | |
180 | (if version | |
181 | (find-packages-by-name name version) | |
182 | (match (vhash-assoc name (find-newest-available-packages)) | |
183 | ((_ version pkgs ...) pkgs) | |
184 | (#f '())))) |