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 MW |
35 | find-packages-by-name |
36 | find-newest-available-packages)) | |
6b1891b0 LC |
37 | |
38 | ;;; Commentary: | |
39 | ;;; | |
40 | ;;; General utilities for the software distribution---i.e., the modules under | |
59a43334 | 41 | ;;; (gnu packages ...). |
6b1891b0 LC |
42 | ;;; |
43 | ;;; Code: | |
44 | ||
45 | (define _ (cut gettext <> "guix")) | |
46 | ||
0b3651bc LC |
47 | ;; By default, we store patches and bootstrap binaries alongside Guile |
48 | ;; modules. This is so that these extra files can be found without | |
49 | ;; requiring a special setup, such as a specific installation directory | |
50 | ;; and an extra environment variable. One advantage of this setup is | |
51 | ;; that everything just works in an auto-compilation setting. | |
a9f60c42 LC |
52 | |
53 | (define %patch-path | |
800cdeef | 54 | (make-parameter |
1ffa7090 | 55 | (map (cut string-append <> "/gnu/packages/patches") |
0b3651bc | 56 | %load-path))) |
800cdeef | 57 | |
a9f60c42 | 58 | (define %bootstrap-binaries-path |
ac5aa288 | 59 | (make-parameter |
1ffa7090 | 60 | (map (cut string-append <> "/gnu/packages/bootstrap") |
0b3651bc | 61 | %load-path))) |
ac5aa288 | 62 | |
800cdeef LC |
63 | (define (search-patch file-name) |
64 | "Search the patch FILE-NAME." | |
128663e4 | 65 | (search-path (%patch-path) file-name)) |
800cdeef | 66 | |
ac5aa288 LC |
67 | (define (search-bootstrap-binary file-name system) |
68 | "Search the bootstrap binary FILE-NAME for SYSTEM." | |
128663e4 LC |
69 | (search-path (%bootstrap-binaries-path) |
70 | (string-append system "/" file-name))) | |
ac5aa288 | 71 | |
6b1891b0 | 72 | (define %distro-module-directory |
1ffa7090 | 73 | ;; Absolute path of the (gnu packages ...) module root. |
59a43334 LC |
74 | (string-append (dirname (search-path %load-path "gnu/packages.scm")) |
75 | "/packages")) | |
6b1891b0 LC |
76 | |
77 | (define (package-files) | |
78 | "Return the list of files that implement distro modules." | |
79 | (define prefix-len | |
59a43334 LC |
80 | (string-length |
81 | (dirname (dirname (search-path %load-path "gnu/packages.scm"))))) | |
6b1891b0 LC |
82 | |
83 | (file-system-fold (const #t) ; enter? | |
84 | (lambda (path stat result) ; leaf | |
85 | (if (string-suffix? ".scm" path) | |
86 | (cons (substring path prefix-len) result) | |
87 | result)) | |
88 | (lambda (path stat result) ; down | |
89 | result) | |
90 | (lambda (path stat result) ; up | |
91 | result) | |
92 | (const #f) ; skip | |
93 | (lambda (path stat errno result) | |
98eb8cbe NK |
94 | (warning (_ "cannot access `~a': ~a~%") |
95 | path (strerror errno)) | |
6b1891b0 LC |
96 | result) |
97 | '() | |
98 | %distro-module-directory | |
99 | stat)) | |
100 | ||
101 | (define (package-modules) | |
102 | "Return the list of modules that provide packages for the distribution." | |
103 | (define not-slash | |
104 | (char-set-complement (char-set #\/))) | |
105 | ||
106 | (filter-map (lambda (path) | |
107 | (let ((name (map string->symbol | |
108 | (string-tokenize (string-drop-right path 4) | |
109 | not-slash)))) | |
110 | (false-if-exception (resolve-interface name)))) | |
111 | (package-files))) | |
112 | ||
ba326ce4 LC |
113 | (define (fold-packages proc init) |
114 | "Call (PROC PACKAGE RESULT) for each available package, using INIT as | |
c2868b1e MW |
115 | the initial value of RESULT. It is guaranteed to never traverse the |
116 | same package twice." | |
117 | (identity ; discard second return value | |
118 | (fold2 (lambda (module result seen) | |
119 | (fold2 (lambda (var result seen) | |
120 | (if (and (package? var) | |
121 | (not (vhash-assq var seen))) | |
122 | (values (proc var result) | |
123 | (vhash-consq var #t seen)) | |
124 | (values result seen))) | |
125 | result | |
126 | seen | |
127 | (module-map (lambda (sym var) | |
128 | (false-if-exception (variable-ref var))) | |
129 | module))) | |
130 | init | |
131 | vlist-null | |
132 | (package-modules)))) | |
ba326ce4 | 133 | |
6b1891b0 LC |
134 | (define* (find-packages-by-name name #:optional version) |
135 | "Return the list of packages with the given NAME. If VERSION is not #f, | |
136 | then only return packages whose version is equal to VERSION." | |
137 | (define right-package? | |
138 | (if version | |
139 | (lambda (p) | |
ba326ce4 | 140 | (and (string=? (package-name p) name) |
6b1891b0 LC |
141 | (string=? (package-version p) version))) |
142 | (lambda (p) | |
ba326ce4 LC |
143 | (string=? (package-name p) name)))) |
144 | ||
145 | (fold-packages (lambda (package result) | |
146 | (if (right-package? package) | |
147 | (cons package result) | |
148 | result)) | |
149 | '())) | |
dc5669cd MW |
150 | |
151 | (define (find-newest-available-packages) | |
152 | "Return a vhash keyed by package names, and with | |
153 | associated values of the form | |
154 | ||
155 | (newest-version newest-package ...) | |
156 | ||
157 | where the preferred package is listed first." | |
158 | ||
159 | ;; FIXME: Currently, the preferred package is whichever one | |
160 | ;; was found last by 'fold-packages'. Find a better solution. | |
161 | (fold-packages (lambda (p r) | |
162 | (let ((name (package-name p)) | |
163 | (version (package-version p))) | |
164 | (match (vhash-assoc name r) | |
165 | ((_ newest-so-far . pkgs) | |
166 | (case (version-compare version newest-so-far) | |
167 | ((>) (vhash-cons name `(,version ,p) r)) | |
168 | ((=) (vhash-cons name `(,version ,p ,@pkgs) r)) | |
169 | ((<) r))) | |
170 | (#f (vhash-cons name `(,version ,p) r))))) | |
171 | vlist-null)) |