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
|
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu packages)
#:use-module (guix packages)
#:use-module (guix utils)
#:use-module (ice-9 ftw)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-39)
#:export (search-patch
search-bootstrap-binary
%patch-directory
%bootstrap-binaries-path
fold-packages
find-packages-by-name
find-newest-available-packages))
;;; Commentary:
;;;
;;; General utilities for the software distribution---i.e., the modules under
;;; (gnu packages ...).
;;;
;;; Code:
(define _ (cut gettext <> "guix"))
;; By default, we store patches and bootstrap binaries alongside Guile
;; modules. This is so that these extra files can be found without
;; requiring a special setup, such as a specific installation directory
;; and an extra environment variable. One advantage of this setup is
;; that everything just works in an auto-compilation setting.
(define %patch-path
(make-parameter
(map (cut string-append <> "/gnu/packages/patches")
%load-path)))
(define %bootstrap-binaries-path
(make-parameter
(map (cut string-append <> "/gnu/packages/bootstrap")
%load-path)))
(define (search-patch file-name)
"Search the patch FILE-NAME."
(with-fluids ((%file-port-name-canonicalization #f))
(search-path (%patch-path) file-name)))
(define (search-bootstrap-binary file-name system)
"Search the bootstrap binary FILE-NAME for SYSTEM."
(with-fluids ((%file-port-name-canonicalization #f))
(search-path (%bootstrap-binaries-path)
(string-append system "/" file-name))))
(define %distro-module-directory
;; Absolute path of the (gnu packages ...) module root.
(string-append (dirname (search-path %load-path "gnu/packages.scm"))
"/packages"))
(define (package-files)
"Return the list of files that implement distro modules."
(define prefix-len
(string-length
(dirname (dirname (search-path %load-path "gnu/packages.scm")))))
(file-system-fold (const #t) ; enter?
(lambda (path stat result) ; leaf
(if (string-suffix? ".scm" path)
(cons (substring path prefix-len) result)
result))
(lambda (path stat result) ; down
result)
(lambda (path stat result) ; up
result)
(const #f) ; skip
(lambda (path stat errno result)
(format (current-error-port)
(_ "warning: cannot access `~a': ~a~%")
path (strerror errno))
result)
'()
%distro-module-directory
stat))
(define (package-modules)
"Return the list of modules that provide packages for the distribution."
(define not-slash
(char-set-complement (char-set #\/)))
(filter-map (lambda (path)
(let ((name (map string->symbol
(string-tokenize (string-drop-right path 4)
not-slash))))
(false-if-exception (resolve-interface name))))
(package-files)))
(define (fold2 f seed1 seed2 lst)
(if (null? lst)
(values seed1 seed2)
(call-with-values
(lambda () (f (car lst) seed1 seed2))
(lambda (seed1 seed2)
(fold2 f seed1 seed2 (cdr lst))))))
(define (fold-packages proc init)
"Call (PROC PACKAGE RESULT) for each available package, using INIT as
the initial value of RESULT. It is guaranteed to never traverse the
same package twice."
(identity ; discard second return value
(fold2 (lambda (module result seen)
(fold2 (lambda (var result seen)
(if (and (package? var)
(not (vhash-assq var seen)))
(values (proc var result)
(vhash-consq var #t seen))
(values result seen)))
result
seen
(module-map (lambda (sym var)
(false-if-exception (variable-ref var)))
module)))
init
vlist-null
(package-modules))))
(define* (find-packages-by-name name #:optional version)
"Return the list of packages with the given NAME. If VERSION is not #f,
then only return packages whose version is equal to VERSION."
(define right-package?
(if version
(lambda (p)
(and (string=? (package-name p) name)
(string=? (package-version p) version)))
(lambda (p)
(string=? (package-name p) name))))
(fold-packages (lambda (package result)
(if (right-package? package)
(cons package result)
result))
'()))
(define (find-newest-available-packages)
"Return a vhash keyed by package names, and with
associated values of the form
(newest-version newest-package ...)
where the preferred package is listed first."
;; FIXME: Currently, the preferred package is whichever one
;; was found last by 'fold-packages'. Find a better solution.
(fold-packages (lambda (p r)
(let ((name (package-name p))
(version (package-version p)))
(match (vhash-assoc name r)
((_ newest-so-far . pkgs)
(case (version-compare version newest-so-far)
((>) (vhash-cons name `(,version ,p) r))
((=) (vhash-cons name `(,version ,p ,@pkgs) r))
((<) r)))
(#f (vhash-cons name `(,version ,p) r)))))
vlist-null))
|
