Commit | Line | Data |
---|---|---|
eaae07ec | 1 | ;;; GNU Guix --- Functional package management for GNU |
10612d61 | 2 | ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
23e2cd15 | 3 | ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> |
eaae07ec LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
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 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
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 | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix self) | |
21 | #:use-module (guix config) | |
22 | #:use-module (guix i18n) | |
23 | #:use-module (guix modules) | |
24 | #:use-module (guix gexp) | |
25 | #:use-module (guix store) | |
26 | #:use-module (guix monads) | |
27 | #:use-module (guix discovery) | |
28 | #:use-module (guix packages) | |
29 | #:use-module (guix sets) | |
eaae07ec | 30 | #:use-module (guix modules) |
1d4ab335 | 31 | #:use-module ((guix utils) #:select (version-major+minor)) |
45779fa6 | 32 | #:use-module ((guix build utils) #:select (find-files)) |
eaae07ec LC |
33 | #:use-module (srfi srfi-1) |
34 | #:use-module (srfi srfi-9) | |
6e54e488 | 35 | #:use-module (srfi srfi-35) |
eaae07ec LC |
36 | #:use-module (ice-9 match) |
37 | #:export (make-config.scm | |
8a0d9bc8 | 38 | whole-package ;for internal use in 'guix pull' |
eaae07ec | 39 | compiled-guix |
567f0d25 | 40 | guix-derivation)) |
eaae07ec LC |
41 | |
42 | \f | |
43 | ;;; | |
44 | ;;; Dependency handling. | |
45 | ;;; | |
46 | ||
eaae07ec LC |
47 | (define specification->package |
48 | ;; Use our own variant of that procedure because that of (gnu packages) | |
49 | ;; would traverse all the .scm files, which is wasteful. | |
50 | (let ((ref (lambda (module variable) | |
51 | (module-ref (resolve-interface module) variable)))) | |
52 | (match-lambda | |
cef392f3 | 53 | ("guile" (ref '(gnu packages guile) 'guile-3.0/libgc-7)) |
44068c7d | 54 | ("guile-avahi" (ref '(gnu packages guile-xyz) 'guile-avahi)) |
b5eb901a | 55 | ("guile-json" (ref '(gnu packages guile) 'guile-json-4)) |
b6bee63b LC |
56 | ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) |
57 | ("guile-git" (ref '(gnu packages guile) 'guile-git)) | |
720e87fe | 58 | ("guile-semver" (ref '(gnu packages guile-xyz) 'guile-semver)) |
02e2e093 | 59 | ("guile-lib" (ref '(gnu packages guile-xyz) 'guile-lib)) |
b6bee63b | 60 | ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) |
4c0c65ac MO |
61 | ("guile-zlib" (ref '(gnu packages guile) 'guile-zlib)) |
62 | ("guile-lzlib" (ref '(gnu packages guile) 'guile-lzlib)) | |
03655f1e | 63 | ("guile-zstd" (ref '(gnu packages guile) 'guile-zstd)) |
b6bee63b | 64 | ("guile-gcrypt" (ref '(gnu packages gnupg) 'guile-gcrypt)) |
79506553 | 65 | ("gnutls" (ref '(gnu packages tls) 'gnutls)) |
eaae07ec LC |
66 | ("gzip" (ref '(gnu packages compression) 'gzip)) |
67 | ("bzip2" (ref '(gnu packages compression) 'bzip2)) | |
68 | ("xz" (ref '(gnu packages compression) 'xz)) | |
554b30d2 JL |
69 | ("po4a" (ref '(gnu packages gettext) 'po4a)) |
70 | ("gettext" (ref '(gnu packages gettext) 'gettext-minimal)) | |
1d4ab335 | 71 | ("gcc-toolchain" (ref '(gnu packages commencement) 'gcc-toolchain)) |
6e54e488 | 72 | (_ #f)))) ;no such package |
eaae07ec LC |
73 | |
74 | \f | |
75 | ;;; | |
76 | ;;; Derivations. | |
77 | ;;; | |
78 | ||
79 | ;; Node in a DAG of build tasks. Each node maps to a derivation, but it's | |
80 | ;; easier to express things this way. | |
81 | (define-record-type <node> | |
82 | (node name modules source dependencies compiled) | |
83 | node? | |
84 | (name node-name) ;string | |
85 | (modules node-modules) ;list of module names | |
86 | (source node-source) ;list of source files | |
87 | (dependencies node-dependencies) ;list of nodes | |
88 | (compiled node-compiled)) ;node -> lowerable object | |
89 | ||
f5db54ea LC |
90 | ;; File mappings are essentially an alist as passed to 'imported-files'. |
91 | (define-record-type <file-mapping> | |
92 | (file-mapping name alist) | |
93 | file-mapping? | |
94 | (name file-mapping-name) | |
95 | (alist file-mapping-alist)) | |
96 | ||
97 | (define-gexp-compiler (file-mapping-compiler (mapping <file-mapping>) | |
98 | system target) | |
99 | ;; Here we use 'imported-files', which can arrange to directly import all | |
100 | ;; the files instead of creating a derivation, when possible. | |
101 | (imported-files (map (match-lambda | |
102 | ((destination (? local-file? file)) | |
103 | (cons destination | |
104 | (local-file-absolute-file-name file))) | |
105 | ((destination source) | |
106 | (cons destination source))) ;silliness | |
107 | (file-mapping-alist mapping)) | |
108 | #:name (file-mapping-name mapping) | |
109 | #:system system)) | |
110 | ||
49c35bbb LC |
111 | (define (node-source+compiled node) |
112 | "Return a \"bundle\" containing both the source code and object files for | |
113 | NODE's modules, under their FHS directories: share/guile/site and lib/guile." | |
114 | (define build | |
115 | (with-imported-modules '((guix build utils)) | |
116 | #~(begin | |
117 | (use-modules (guix build utils)) | |
118 | ||
119 | (define source | |
120 | (string-append #$output "/share/guile/site/" | |
121 | (effective-version))) | |
122 | ||
123 | (define object | |
124 | (string-append #$output "/lib/guile/" (effective-version) | |
125 | "/site-ccache")) | |
126 | ||
127 | (mkdir-p (dirname source)) | |
128 | (symlink #$(node-source node) source) | |
129 | (mkdir-p (dirname object)) | |
130 | (symlink #$(node-compiled node) object)))) | |
131 | ||
132 | (computed-file (string-append (node-name node) "-modules") | |
8727e030 LC |
133 | build |
134 | #:options '(#:local-build? #t | |
135 | ||
136 | ;; "Building" it locally is faster. | |
137 | #:substitutable? #f))) | |
49c35bbb | 138 | |
eaae07ec LC |
139 | (define (node-fold proc init nodes) |
140 | (let loop ((nodes nodes) | |
141 | (visited (setq)) | |
142 | (result init)) | |
143 | (match nodes | |
144 | (() result) | |
145 | ((head tail ...) | |
146 | (if (set-contains? visited head) | |
147 | (loop tail visited result) | |
148 | (loop tail (set-insert head visited) | |
149 | (proc head result))))))) | |
150 | ||
151 | (define (node-modules/recursive nodes) | |
152 | (node-fold (lambda (node modules) | |
153 | (append (node-modules node) modules)) | |
154 | '() | |
155 | nodes)) | |
156 | ||
157 | (define* (closure modules #:optional (except '())) | |
158 | (source-module-closure modules | |
159 | #:select? | |
160 | (match-lambda | |
161 | (('guix 'config) | |
162 | #f) | |
163 | ((and module | |
164 | (or ('guix _ ...) ('gnu _ ...))) | |
165 | (not (member module except))) | |
166 | (rest #f)))) | |
167 | ||
168 | (define module->import | |
169 | ;; Return a file-name/file-like object pair for the specified module and | |
170 | ;; suitable for 'imported-files'. | |
171 | (match-lambda | |
172 | ((module '=> thing) | |
173 | (let ((file (module-name->file-name module))) | |
174 | (list file thing))) | |
175 | (module | |
176 | (let ((file (module-name->file-name module))) | |
177 | (list file | |
178 | (local-file (search-path %load-path file))))))) | |
179 | ||
180 | (define* (scheme-node name modules #:optional (dependencies '()) | |
181 | #:key (extra-modules '()) (extra-files '()) | |
182 | (extensions '()) | |
183 | parallel? guile-for-build) | |
184 | "Return a node that builds the given Scheme MODULES, and depends on | |
185 | DEPENDENCIES (a list of nodes). EXTRA-MODULES is a list of additional modules | |
186 | added to the source, and EXTRA-FILES is a list of additional files. | |
187 | EXTENSIONS is a set of full-blown Guile packages (e.g., 'guile-json') that | |
188 | must be present in the search path." | |
189 | (let* ((modules (append extra-modules | |
190 | (closure modules | |
191 | (node-modules/recursive dependencies)))) | |
192 | (module-files (map module->import modules)) | |
f5db54ea LC |
193 | (source (file-mapping (string-append name "-source") |
194 | (append module-files extra-files)))) | |
eaae07ec | 195 | (node name modules source dependencies |
8031b3fa LC |
196 | (compiled-modules name source |
197 | (map car module-files) | |
eaae07ec LC |
198 | (map node-source dependencies) |
199 | (map node-compiled dependencies) | |
200 | #:extensions extensions | |
201 | #:parallel? parallel? | |
202 | #:guile-for-build guile-for-build)))) | |
203 | ||
204 | (define (file-imports directory sub-directory pred) | |
205 | "List all the files matching PRED under DIRECTORY/SUB-DIRECTORY. Return a | |
206 | list of file-name/file-like objects suitable as inputs to 'imported-files'." | |
207 | (map (lambda (file) | |
208 | (list (string-drop file (+ 1 (string-length directory))) | |
209 | (local-file file #:recursive? #t))) | |
210 | (find-files (string-append directory "/" sub-directory) pred))) | |
211 | ||
6cf502d1 LC |
212 | (define* (file-append* item file #:key (recursive? #t)) |
213 | "Return FILE within ITEM, which may be a file name or a file-like object. | |
214 | When ITEM is a plain file name (a string), simply return a 'local-file' | |
215 | record with the new file name." | |
9f1c3559 LC |
216 | (match item |
217 | ((? string?) | |
218 | ;; This is the optimal case: we return a new "source". Thus, a | |
219 | ;; derivation that depends on this sub-directory does not depend on ITEM | |
220 | ;; itself. | |
6cf502d1 LC |
221 | (local-file (string-append item "/" file) |
222 | #:recursive? recursive?)) | |
f408d8d6 LC |
223 | ((? local-file? base) |
224 | ;; Likewise, but with a <local-file>. | |
225 | (if (local-file-recursive? base) | |
226 | (local-file (string-append (local-file-absolute-file-name base) | |
227 | "/" file) | |
228 | (basename file) | |
229 | #:recursive? recursive? | |
230 | #:select? (local-file-select? base)) | |
231 | (file-append base file))) | |
9f1c3559 LC |
232 | (_ |
233 | ;; In this case, anything that refers to the result also depends on ITEM, | |
234 | ;; which isn't great. | |
6cf502d1 | 235 | (file-append item "/" file)))) |
9f1c3559 LC |
236 | |
237 | (define* (locale-data source domain | |
238 | #:optional (directory domain)) | |
239 | "Return the locale data from 'po/DIRECTORY' in SOURCE, corresponding to | |
240 | DOMAIN, a gettext domain." | |
241 | (define gettext | |
242 | (module-ref (resolve-interface '(gnu packages gettext)) | |
243 | 'gettext-minimal)) | |
244 | ||
245 | (define build | |
246 | (with-imported-modules '((guix build utils)) | |
247 | #~(begin | |
248 | (use-modules (guix build utils) | |
249 | (srfi srfi-26) | |
250 | (ice-9 match) (ice-9 ftw)) | |
251 | ||
252 | (define po-directory | |
6cf502d1 | 253 | #+(file-append* source (string-append "po/" directory))) |
9f1c3559 LC |
254 | |
255 | (define (compile language) | |
256 | (let ((gmo (string-append #$output "/" language "/LC_MESSAGES/" | |
257 | #$domain ".mo"))) | |
258 | (mkdir-p (dirname gmo)) | |
259 | (invoke #+(file-append gettext "/bin/msgfmt") | |
260 | "-c" "--statistics" "--verbose" | |
261 | "-o" gmo | |
262 | (string-append po-directory "/" language ".po")))) | |
263 | ||
264 | (define (linguas) | |
265 | ;; Return the list of languages. Note: don't read 'LINGUAS' | |
266 | ;; because it contains things like 'en@boldquot' that do not have | |
267 | ;; a corresponding .po file. | |
268 | (map (cut basename <> ".po") | |
269 | (scandir po-directory | |
270 | (cut string-suffix? ".po" <>)))) | |
271 | ||
272 | (for-each compile (linguas))))) | |
273 | ||
274 | (computed-file (string-append "guix-locale-" domain) | |
275 | build)) | |
276 | ||
554b30d2 JL |
277 | (define (translate-texi-manuals source) |
278 | "Return the translated texinfo manuals built from SOURCE." | |
279 | (define po4a | |
280 | (specification->package "po4a")) | |
281 | ||
282 | (define gettext | |
283 | (specification->package "gettext")) | |
284 | ||
285 | (define glibc-utf8-locales | |
286 | (module-ref (resolve-interface '(gnu packages base)) | |
287 | 'glibc-utf8-locales)) | |
288 | ||
289 | (define documentation | |
290 | (file-append* source "doc")) | |
291 | ||
292 | (define documentation-po | |
293 | (file-append* source "po/doc")) | |
294 | ||
295 | (define build | |
296 | (with-imported-modules '((guix build utils) (guix build po)) | |
297 | #~(begin | |
298 | (use-modules (guix build utils) (guix build po) | |
299 | (ice-9 match) (ice-9 regex) (ice-9 textual-ports) | |
2f6901c9 | 300 | (ice-9 vlist) (ice-9 threads) |
554b30d2 JL |
301 | (srfi srfi-1)) |
302 | ||
554b30d2 JL |
303 | (define (translate-tmp-texi po source output) |
304 | "Translate Texinfo file SOURCE using messages from PO, and write | |
305 | the result to OUTPUT." | |
306 | (invoke #+(file-append po4a "/bin/po4a-translate") | |
307 | "-M" "UTF-8" "-L" "UTF-8" "-k" "0" "-f" "texinfo" | |
308 | "-m" source "-p" po "-l" output)) | |
309 | ||
a524a31d LC |
310 | (define (canonicalize-whitespace str) |
311 | ;; Change whitespace (newlines, etc.) in STR to #\space. | |
312 | (string-map (lambda (chr) | |
313 | (if (char-set-contains? char-set:whitespace chr) | |
314 | #\space | |
315 | chr)) | |
316 | str)) | |
317 | ||
318 | (define xref-regexp | |
319 | ;; Texinfo cross-reference regexp. | |
320 | (make-regexp "@(px|x)?ref\\{([^,}]+)")) | |
321 | ||
322 | (define (translate-cross-references texi translations) | |
323 | ;; Translate the cross-references that appear in TEXI, a Texinfo | |
324 | ;; file, using the msgid/msgstr pairs from TRANSLATIONS. | |
325 | (define content | |
326 | (call-with-input-file texi get-string-all)) | |
327 | ||
328 | (define matches | |
329 | (list-matches xref-regexp content)) | |
330 | ||
331 | (define translation-map | |
332 | (fold (match-lambda* | |
333 | (((msgid . str) result) | |
334 | (vhash-cons msgid str result))) | |
335 | vlist-null | |
336 | translations)) | |
337 | ||
338 | (define translated | |
339 | ;; Iterate over MATCHES and replace cross-references with their | |
340 | ;; translation found in TRANSLATION-MAP. (We can't use | |
341 | ;; 'substitute*' because matches can span multiple lines.) | |
342 | (let loop ((matches matches) | |
343 | (offset 0) | |
344 | (result '())) | |
345 | (match matches | |
346 | (() | |
347 | (string-concatenate-reverse | |
348 | (cons (string-drop content offset) result))) | |
349 | ((head . tail) | |
350 | (let ((prefix (match:substring head 1)) | |
351 | (ref (canonicalize-whitespace (match:substring head 2)))) | |
352 | (define translated | |
353 | (string-append "@" (or prefix "") | |
354 | "ref{" | |
355 | (match (vhash-assoc ref translation-map) | |
356 | (#f ref) | |
357 | ((_ . str) str)))) | |
358 | ||
359 | (loop tail | |
360 | (match:end head) | |
361 | (append (list translated | |
362 | (string-take | |
363 | (string-drop content offset) | |
364 | (- (match:start head) offset))) | |
365 | result))))))) | |
366 | ||
367 | (format (current-error-port) | |
368 | "translated ~a cross-references in '~a'~%" | |
369 | (length matches) texi) | |
370 | (call-with-output-file texi | |
371 | (lambda (port) | |
372 | (display translated port)))) | |
cc753650 LC |
373 | |
374 | (define* (translate-texi prefix po lang | |
375 | #:key (extras '())) | |
376 | "Translate the manual for one language LANG using the PO file. | |
377 | PREFIX must be the prefix of the manual, 'guix' or 'guix-cookbook'. EXTRAS is | |
378 | a list of extra files, such as '(\"contributing\")." | |
554b30d2 | 379 | (let ((translations (call-with-input-file po read-po-file))) |
cc753650 LC |
380 | (for-each (lambda (file) |
381 | (translate-tmp-texi po (string-append file ".texi") | |
382 | (string-append file "." lang | |
383 | ".texi.tmp"))) | |
384 | (cons prefix extras)) | |
385 | ||
386 | (for-each (lambda (file) | |
387 | (let* ((texi (string-append file "." lang ".texi")) | |
388 | (tmp (string-append texi ".tmp"))) | |
a524a31d LC |
389 | (copy-file tmp texi) |
390 | (translate-cross-references texi | |
391 | translations))) | |
cc753650 | 392 | (cons prefix extras)))) |
554b30d2 | 393 | |
84c37e63 LC |
394 | (define (available-translations directory domain) |
395 | ;; Return the list of available translations under DIRECTORY for | |
396 | ;; DOMAIN, a gettext domain such as "guix-manual". The result is | |
397 | ;; a list of language/PO file pairs. | |
398 | (filter-map (lambda (po) | |
399 | (let ((base (basename po))) | |
400 | (and (string-prefix? (string-append domain ".") | |
401 | base) | |
402 | (match (string-split base #\.) | |
403 | ((_ ... lang "po") | |
404 | (cons lang po)))))) | |
405 | (find-files directory | |
406 | "\\.[a-z]{2}(_[A-Z]{2})?\\.po$"))) | |
407 | ||
98750a9d LC |
408 | (define parallel-jobs |
409 | ;; Limit thread creation by 'n-par-for-each'. Going beyond can | |
410 | ;; lead libgc 8.0.4 to abort with: | |
411 | ;; mmap(PROT_NONE) failed | |
412 | (min (parallel-job-count) 4)) | |
413 | ||
301527be LC |
414 | (mkdir #$output) |
415 | (copy-recursively #$documentation "." | |
416 | #:log (%make-void-port "w")) | |
417 | ||
418 | (for-each | |
419 | (lambda (file) | |
420 | (copy-file file (basename file))) | |
421 | (find-files #$documentation-po ".*.po$")) | |
422 | ||
423 | (setenv "GUIX_LOCPATH" | |
424 | #+(file-append glibc-utf8-locales "/lib/locale")) | |
425 | (setenv "PATH" #+(file-append gettext "/bin")) | |
426 | (setenv "LC_ALL" "en_US.UTF-8") | |
427 | (setlocale LC_ALL "en_US.UTF-8") | |
428 | ||
98750a9d | 429 | (n-par-for-each parallel-jobs |
2f6901c9 LC |
430 | (match-lambda |
431 | ((language . po) | |
432 | (translate-texi "guix" po language | |
433 | #:extras '("contributing")))) | |
434 | (available-translations "." "guix-manual")) | |
435 | ||
98750a9d | 436 | (n-par-for-each parallel-jobs |
2f6901c9 LC |
437 | (match-lambda |
438 | ((language . po) | |
439 | (translate-texi "guix-cookbook" po language))) | |
440 | (available-translations "." "guix-cookbook")) | |
554b30d2 | 441 | |
e1e64912 LC |
442 | (for-each (lambda (file) |
443 | (install-file file #$output)) | |
444 | (append | |
445 | (find-files "." "contributing\\..*\\.texi$") | |
446 | (find-files "." "guix\\..*\\.texi$") | |
447 | (find-files "." "guix-cookbook\\..*\\.texi$")))))) | |
554b30d2 JL |
448 | |
449 | (computed-file "guix-translated-texinfo" build)) | |
450 | ||
4554d4c8 LC |
451 | (define (info-manual source) |
452 | "Return the Info manual built from SOURCE." | |
453 | (define texinfo | |
454 | (module-ref (resolve-interface '(gnu packages texinfo)) | |
455 | 'texinfo)) | |
456 | ||
457 | (define graphviz | |
458 | (module-ref (resolve-interface '(gnu packages graphviz)) | |
459 | 'graphviz)) | |
460 | ||
2d337760 LC |
461 | (define glibc-utf8-locales |
462 | (module-ref (resolve-interface '(gnu packages base)) | |
463 | 'glibc-utf8-locales)) | |
464 | ||
4554d4c8 | 465 | (define documentation |
6cf502d1 | 466 | (file-append* source "doc")) |
4554d4c8 LC |
467 | |
468 | (define examples | |
6cf502d1 | 469 | (file-append* source "gnu/system/examples")) |
4554d4c8 LC |
470 | |
471 | (define build | |
472 | (with-imported-modules '((guix build utils)) | |
473 | #~(begin | |
e1e64912 LC |
474 | (use-modules (guix build utils) |
475 | (ice-9 match)) | |
4554d4c8 LC |
476 | |
477 | (mkdir #$output) | |
478 | ||
479 | ;; Create 'version.texi'. | |
480 | ;; XXX: Can we use a more meaningful version string yet one that | |
481 | ;; doesn't change at each commit? | |
482 | (call-with-output-file "version.texi" | |
483 | (lambda (port) | |
cbe7387c | 484 | (let ((version "0.0-git")) |
4554d4c8 LC |
485 | (format port " |
486 | @set UPDATED 1 January 1970 | |
487 | @set UPDATED-MONTH January 1970 | |
488 | @set EDITION ~a | |
489 | @set VERSION ~a\n" version version)))) | |
490 | ||
491 | ;; Copy configuration templates that the manual includes. | |
492 | (for-each (lambda (template) | |
493 | (copy-file template | |
494 | (string-append | |
495 | "os-config-" | |
496 | (basename template ".tmpl") | |
497 | ".texi"))) | |
498 | (find-files #$examples "\\.tmpl$")) | |
499 | ||
500 | ;; Build graphs. | |
501 | (mkdir-p (string-append #$output "/images")) | |
502 | (for-each (lambda (dot-file) | |
503 | (invoke #+(file-append graphviz "/bin/dot") | |
504 | "-Tpng" "-Gratio=.9" "-Gnodesep=.005" | |
505 | "-Granksep=.00005" "-Nfontsize=9" | |
506 | "-Nheight=.1" "-Nwidth=.1" | |
507 | "-o" (string-append #$output "/images/" | |
508 | (basename dot-file ".dot") | |
509 | ".png") | |
510 | dot-file)) | |
511 | (find-files (string-append #$documentation "/images") | |
512 | "\\.dot$")) | |
513 | ||
514 | ;; Copy other PNGs. | |
515 | (for-each (lambda (png-file) | |
516 | (install-file png-file | |
517 | (string-append #$output "/images"))) | |
518 | (find-files (string-append #$documentation "/images") | |
519 | "\\.png$")) | |
520 | ||
521 | ;; Finally build the manual. Copy it the Texinfo files to $PWD and | |
522 | ;; add a symlink to the 'images' directory so that 'makeinfo' can | |
523 | ;; see those images and produce image references in the Info output. | |
524 | (copy-recursively #$documentation "." | |
525 | #:log (%make-void-port "w")) | |
554b30d2 JL |
526 | (copy-recursively #+(translate-texi-manuals source) "." |
527 | #:log (%make-void-port "w")) | |
4554d4c8 LC |
528 | (delete-file-recursively "images") |
529 | (symlink (string-append #$output "/images") "images") | |
530 | ||
2d337760 LC |
531 | ;; Provide UTF-8 locales needed by the 'xspara.c' code in makeinfo. |
532 | (setenv "GUIX_LOCPATH" | |
533 | #+(file-append glibc-utf8-locales "/lib/locale")) | |
534 | ||
4554d4c8 | 535 | (for-each (lambda (texi) |
e1e64912 LC |
536 | (match (string-split (basename texi) #\.) |
537 | (("guix" language "texi") | |
538 | ;; Create 'version-LL.texi'. | |
539 | (symlink "version.texi" | |
540 | (string-append "version-" language | |
541 | ".texi"))) | |
542 | (_ #f)) | |
4554d4c8 LC |
543 | |
544 | (invoke #+(file-append texinfo "/bin/makeinfo") | |
545 | texi "-I" #$documentation | |
546 | "-I" "." | |
547 | "-o" (string-append #$output "/" | |
548 | (basename texi ".texi") | |
549 | ".info"))) | |
550 | (cons "guix.texi" | |
e1e64912 LC |
551 | (append (find-files "." |
552 | "^guix\\.[a-z]{2}(_[A-Z]{2})?\\.texi$") | |
553 | (find-files "." | |
554 | "^guix-cookbook.*\\.texi$")))) | |
08fdee39 LC |
555 | |
556 | ;; Compress Info files. | |
557 | (setenv "PATH" | |
558 | #+(file-append (specification->package "gzip") "/bin")) | |
559 | (for-each (lambda (file) | |
560 | (invoke "gzip" "-9n" file)) | |
561 | (find-files #$output "\\.info(-[0-9]+)?$"))))) | |
4554d4c8 LC |
562 | |
563 | (computed-file "guix-manual" build)) | |
564 | ||
b36217c5 LC |
565 | (define-syntax-rule (prevent-inlining! identifier ...) |
566 | (begin (set! identifier identifier) ...)) | |
567 | ||
568 | ;; XXX: These procedures are actually used by 'doc/build.scm'. Protect them | |
569 | ;; from inlining on Guile 3. | |
570 | (prevent-inlining! file-append* translate-texi-manuals info-manual) | |
571 | ||
49c35bbb LC |
572 | (define* (guile-module-union things #:key (name "guix-module-union")) |
573 | "Return the union of the subset of THINGS (packages, computed files, etc.) | |
574 | that provide Guile modules." | |
575 | (define build | |
576 | (with-imported-modules '((guix build union)) | |
577 | #~(begin | |
578 | (use-modules (guix build union)) | |
579 | ||
580 | (define (modules directory) | |
581 | (string-append directory "/share/guile/site")) | |
582 | ||
583 | (define (objects directory) | |
584 | (string-append directory "/lib/guile")) | |
585 | ||
586 | (union-build #$output | |
587 | (filter (lambda (directory) | |
588 | (or (file-exists? (modules directory)) | |
589 | (file-exists? (objects directory)))) | |
590 | '#$things) | |
591 | ||
592 | #:log-port (%make-void-port "w"))))) | |
593 | ||
594 | (computed-file name build)) | |
595 | ||
1d4ab335 LC |
596 | (define (quiet-guile guile) |
597 | "Return a wrapper that does the same as the 'guile' executable of GUILE, | |
598 | except that it does not complain about locales and falls back to 'en_US.utf8' | |
599 | instead of 'C'." | |
600 | (define gcc | |
601 | (specification->package "gcc-toolchain")) | |
602 | ||
603 | (define source | |
604 | (search-path %load-path | |
605 | "gnu/packages/aux-files/guile-launcher.c")) | |
606 | ||
607 | (define effective | |
608 | (version-major+minor (package-version guile))) | |
609 | ||
610 | (define build | |
611 | ;; XXX: Reuse <c-compiler> from (guix scripts pack) instead? | |
612 | (with-imported-modules '((guix build utils)) | |
613 | #~(begin | |
614 | (use-modules (guix build utils) | |
615 | (srfi srfi-26)) | |
616 | ||
617 | (mkdir-p (string-append #$output "/bin")) | |
618 | ||
619 | (setenv "PATH" #$(file-append gcc "/bin")) | |
620 | (setenv "C_INCLUDE_PATH" | |
621 | (string-join | |
622 | (map (cut string-append <> "/include") | |
623 | '#$(match (bag-transitive-build-inputs | |
624 | (package->bag guile)) | |
625 | (((labels packages . _) ...) | |
626 | (filter package? packages)))) | |
627 | ":")) | |
628 | (setenv "LIBRARY_PATH" #$(file-append gcc "/lib")) | |
629 | ||
630 | (invoke "gcc" #$(local-file source) "-Wall" "-g0" "-O2" | |
631 | "-I" #$(file-append guile "/include/guile/" effective) | |
632 | "-L" #$(file-append guile "/lib") | |
633 | #$(string-append "-lguile-" effective) | |
634 | "-o" (string-append #$output "/bin/guile"))))) | |
635 | ||
636 | (computed-file "guile-wrapper" build)) | |
637 | ||
49c35bbb | 638 | (define* (guix-command modules |
a89faa3f | 639 | #:key source (dependencies '()) |
8970a886 | 640 | guile (guile-version (effective-version))) |
8a0d9bc8 LC |
641 | "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its |
642 | load path." | |
ba488958 LC |
643 | (define glibc-utf8-locales |
644 | (module-ref (resolve-interface '(gnu packages base)) | |
645 | 'glibc-utf8-locales)) | |
646 | ||
49c35bbb LC |
647 | (define module-directory |
648 | ;; To minimize the number of 'stat' calls needed to locate a module, | |
649 | ;; create the union of all the module directories. | |
650 | (guile-module-union (cons modules dependencies))) | |
f2d0a2cf | 651 | |
8a0d9bc8 LC |
652 | (program-file "guix-command" |
653 | #~(begin | |
41d01b4e LC |
654 | ;; Remove the empty extension from the search path. |
655 | (set! %load-extensions '(".scm")) | |
656 | ||
8a0d9bc8 | 657 | (set! %load-path |
459f0d07 LC |
658 | (append (list (string-append #$module-directory |
659 | "/share/guile/site/" | |
660 | (effective-version)) | |
661 | (string-append #$guile "/share/guile/" | |
662 | (effective-version))) | |
663 | %load-path)) | |
8a0d9bc8 | 664 | |
8a0d9bc8 | 665 | (set! %load-compiled-path |
459f0d07 LC |
666 | (append (list (string-append #$module-directory |
667 | "/lib/guile/" | |
668 | (effective-version) | |
669 | "/site-ccache") | |
670 | (string-append #$guile "/lib/guile/" | |
671 | (effective-version) | |
672 | "/ccache")) | |
673 | %load-compiled-path)) | |
8a0d9bc8 | 674 | |
ba488958 LC |
675 | ;; To maximize the chances that locales are set up right |
676 | ;; out-of-the-box, bundle "common" UTF-8 locales. | |
677 | (let ((locpath (getenv "GUIX_LOCPATH"))) | |
678 | (setenv "GUIX_LOCPATH" | |
679 | (string-append (if locpath | |
680 | (string-append locpath ":") | |
681 | "") | |
682 | #$(file-append glibc-utf8-locales | |
683 | "/lib/locale")))) | |
684 | ||
8a0d9bc8 LC |
685 | (let ((guix-main (module-ref (resolve-interface '(guix ui)) |
686 | 'guix-main))) | |
9f1c3559 LC |
687 | #$(if source |
688 | #~(begin | |
689 | (bindtextdomain "guix" | |
690 | #$(locale-data source "guix")) | |
691 | (bindtextdomain "guix-packages" | |
692 | #$(locale-data source | |
693 | "guix-packages" | |
694 | "packages"))) | |
695 | #t) | |
8a0d9bc8 LC |
696 | |
697 | ;; XXX: It would be more convenient to change it to: | |
698 | ;; (exit (apply guix-main (command-line))) | |
8970a886 | 699 | (apply guix-main (command-line)))) |
1d4ab335 LC |
700 | |
701 | ;; Use a 'guile' variant that doesn't complain about locales. | |
702 | #:guile (quiet-guile guile))) | |
8a0d9bc8 | 703 | |
e3744779 LC |
704 | (define (miscellaneous-files source) |
705 | "Return data files taken from SOURCE." | |
706 | (file-mapping "guix-misc" | |
707 | `(("etc/bash_completion.d/guix" | |
708 | ,(file-append* source "/etc/completion/bash/guix")) | |
709 | ("etc/bash_completion.d/guix-daemon" | |
710 | ,(file-append* source "/etc/completion/bash/guix-daemon")) | |
711 | ("share/zsh/site-functions/_guix" | |
712 | ,(file-append* source "/etc/completion/zsh/_guix")) | |
713 | ("share/fish/vendor_completions.d/guix.fish" | |
714 | ,(file-append* source "/etc/completion/fish/guix.fish")) | |
d283bb96 | 715 | ("share/guix/berlin.guix.gnu.org.pub" |
6a837b60 | 716 | ,(file-append* source |
d283bb96 | 717 | "/etc/substitutes/berlin.guix.gnu.org.pub")) |
757e633d | 718 | ("share/guix/ci.guix.gnu.org.pub" ;alias |
d283bb96 | 719 | ,(file-append* source "/etc/substitutes/berlin.guix.gnu.org.pub")) |
6a837b60 | 720 | ("share/guix/ci.guix.info.pub" ;alias |
d283bb96 | 721 | ,(file-append* source "/etc/substitutes/berlin.guix.gnu.org.pub"))))) |
e3744779 | 722 | |
8a0d9bc8 | 723 | (define* (whole-package name modules dependencies |
9f1c3559 LC |
724 | #:key |
725 | (guile-version (effective-version)) | |
e3744779 | 726 | info daemon miscellany |
8d3beb3a | 727 | guile |
9f1c3559 LC |
728 | (command (guix-command modules |
729 | #:dependencies dependencies | |
8970a886 | 730 | #:guile guile |
9f1c3559 | 731 | #:guile-version guile-version))) |
8a0d9bc8 | 732 | "Return the whole Guix package NAME that uses MODULES, a derivation of all |
49c35bbb LC |
733 | the modules (under share/guile/site and lib/guile), and DEPENDENCIES, a list |
734 | of packages depended on. COMMAND is the 'guix' program to use; INFO is the | |
735 | Info manual." | |
765a5bf1 LC |
736 | (define (wrap daemon) |
737 | (program-file "guix-daemon" | |
738 | #~(begin | |
dfc69e4b LC |
739 | ;; Refer to the right 'guix' command for 'guix |
740 | ;; substitute' & co. | |
765a5bf1 | 741 | (setenv "GUIX" #$command) |
dfc69e4b LC |
742 | |
743 | ;; Honor the user's settings rather than those hardcoded | |
744 | ;; in the 'guix-daemon' package. | |
745 | (unless (getenv "GUIX_STATE_DIRECTORY") | |
746 | (setenv "GUIX_STATE_DIRECTORY" | |
747 | #$(string-append %localstatedir "/guix"))) | |
748 | (unless (getenv "GUIX_CONFIGURATION_DIRECTORY") | |
749 | (setenv "GUIX_CONFIGURATION_DIRECTORY" | |
750 | #$(string-append %sysconfdir "/guix"))) | |
751 | (unless (getenv "NIX_STORE_DIR") | |
fa866548 | 752 | (setenv "NIX_STORE_DIR" #$%storedir)) |
dfc69e4b | 753 | |
765a5bf1 LC |
754 | (apply execl #$(file-append daemon "/bin/guix-daemon") |
755 | "guix-daemon" (cdr (command-line)))))) | |
756 | ||
9f1c3559 LC |
757 | (computed-file name |
758 | (with-imported-modules '((guix build utils)) | |
759 | #~(begin | |
760 | (use-modules (guix build utils)) | |
e3744779 | 761 | |
765a5bf1 LC |
762 | (define daemon |
763 | #$(and daemon (wrap daemon))) | |
764 | ||
9f1c3559 LC |
765 | (mkdir-p (string-append #$output "/bin")) |
766 | (symlink #$command | |
767 | (string-append #$output "/bin/guix")) | |
768 | ||
765a5bf1 LC |
769 | (when daemon |
770 | (symlink daemon | |
baed9236 LC |
771 | (string-append #$output "/bin/guix-daemon"))) |
772 | ||
49c35bbb LC |
773 | (let ((share (string-append #$output "/share")) |
774 | (lib (string-append #$output "/lib")) | |
775 | (info #$info)) | |
776 | (mkdir-p share) | |
777 | (symlink #$(file-append modules "/share/guile") | |
778 | (string-append share "/guile")) | |
4554d4c8 | 779 | (when info |
49c35bbb LC |
780 | (symlink #$info (string-append share "/info"))) |
781 | ||
782 | (mkdir-p lib) | |
783 | (symlink #$(file-append modules "/lib/guile") | |
784 | (string-append lib "/guile"))) | |
a89faa3f | 785 | |
e3744779 LC |
786 | (when #$miscellany |
787 | (copy-recursively #$miscellany #$output | |
49c35bbb | 788 | #:log (%make-void-port "w"))))))) |
8a0d9bc8 | 789 | |
fbb380a0 LC |
790 | (define (transitive-package-dependencies package) |
791 | "Return the list of packages propagated by PACKAGE, including PACKAGE | |
792 | itself." | |
793 | (match (package-transitive-propagated-inputs package) | |
794 | (((labels packages _ ...) ...) | |
795 | (cons package packages)))) | |
796 | ||
316fc2ac LC |
797 | (define* (compiled-guix source #:key |
798 | (version %guix-version) | |
799 | (channel-metadata #f) | |
8a0d9bc8 | 800 | (pull-version 1) |
eaae07ec LC |
801 | (name (string-append "guix-" version)) |
802 | (guile-version (effective-version)) | |
6e54e488 | 803 | (guile-for-build (default-guile)) |
eaae07ec LC |
804 | (gzip (specification->package "gzip")) |
805 | (bzip2 (specification->package "bzip2")) | |
806 | (xz (specification->package "xz")) | |
807 | (guix (specification->package "guix"))) | |
808 | "Return a file-like object that contains a compiled Guix." | |
375cc7de MO |
809 | (define guile-avahi |
810 | (specification->package "guile-avahi")) | |
811 | ||
eaae07ec | 812 | (define guile-json |
6e54e488 | 813 | (specification->package "guile-json")) |
eaae07ec LC |
814 | |
815 | (define guile-ssh | |
6e54e488 | 816 | (specification->package "guile-ssh")) |
eaae07ec | 817 | |
02e2e093 KCB |
818 | (define guile-lib |
819 | (specification->package "guile-lib")) | |
820 | ||
eaae07ec | 821 | (define guile-git |
6e54e488 | 822 | (specification->package "guile-git")) |
eaae07ec | 823 | |
d59e75f3 | 824 | (define guile-sqlite3 |
6e54e488 | 825 | (specification->package "guile-sqlite3")) |
d59e75f3 | 826 | |
4c0c65ac MO |
827 | (define guile-zlib |
828 | (specification->package "guile-zlib")) | |
829 | ||
830 | (define guile-lzlib | |
831 | (specification->package "guile-lzlib")) | |
832 | ||
03655f1e LC |
833 | (define guile-zstd |
834 | (specification->package "guile-zstd")) | |
835 | ||
ca719424 | 836 | (define guile-gcrypt |
6e54e488 | 837 | (specification->package "guile-gcrypt")) |
ca719424 | 838 | |
23e2cd15 MB |
839 | (define guile-semver |
840 | (specification->package "guile-semver")) | |
841 | ||
108015df | 842 | (define gnutls |
6e54e488 | 843 | (specification->package "gnutls")) |
108015df | 844 | |
eaae07ec | 845 | (define dependencies |
fbb380a0 LC |
846 | (append-map transitive-package-dependencies |
847 | (list guile-gcrypt gnutls guile-git guile-avahi | |
848 | guile-json guile-semver guile-ssh guile-sqlite3 | |
02e2e093 | 849 | guile-lib guile-zlib guile-lzlib guile-zstd))) |
eaae07ec LC |
850 | |
851 | (define *core-modules* | |
852 | (scheme-node "guix-core" | |
853 | '((guix) | |
854 | (guix monad-repl) | |
855 | (guix packages) | |
856 | (guix download) | |
857 | (guix discovery) | |
858 | (guix profiles) | |
859 | (guix build-system gnu) | |
860 | (guix build-system trivial) | |
861 | (guix build profiles) | |
862 | (guix build gnu-build-system)) | |
863 | ||
864 | ;; Provide a dummy (guix config) with the default version | |
865 | ;; number, storedir, etc. This is so that "guix-core" is the | |
866 | ;; same across all installations and doesn't need to be | |
867 | ;; rebuilt when the version changes, which in turn means we | |
868 | ;; can have substitutes for it. | |
869 | #:extra-modules | |
ca719424 | 870 | `(((guix config) => ,(make-config.scm))) |
eaae07ec | 871 | |
8292f5a9 LC |
872 | ;; (guix man-db) is needed at build-time by (guix profiles) |
873 | ;; but we don't need to compile it; not compiling it allows | |
874 | ;; us to avoid an extra dependency on guile-gdbm-ffi. | |
875 | #:extra-files | |
3931c761 | 876 | `(("guix/man-db.scm" ,(local-file "../guix/man-db.scm")) |
554b30d2 | 877 | ("guix/build/po.scm" ,(local-file "../guix/build/po.scm")) |
3931c761 LC |
878 | ("guix/store/schema.sql" |
879 | ,(local-file "../guix/store/schema.sql"))) | |
8292f5a9 | 880 | |
ca719424 | 881 | #:extensions (list guile-gcrypt) |
eaae07ec LC |
882 | #:guile-for-build guile-for-build)) |
883 | ||
884 | (define *extra-modules* | |
885 | (scheme-node "guix-extra" | |
886 | (filter-map (match-lambda | |
887 | (('guix 'scripts _ ..1) #f) | |
8292f5a9 | 888 | (('guix 'man-db) #f) |
852d30a6 | 889 | (('guix 'tests _ ...) #f) |
eaae07ec LC |
890 | (name name)) |
891 | (scheme-modules* source "guix")) | |
892 | (list *core-modules*) | |
10612d61 LC |
893 | |
894 | #:extra-files | |
895 | `(("guix/graph.js" ,(local-file "../guix/graph.js")) | |
896 | ("guix/d3.v3.js" ,(local-file "../guix/d3.v3.js"))) | |
897 | ||
eaae07ec LC |
898 | #:extensions dependencies |
899 | #:guile-for-build guile-for-build)) | |
900 | ||
f2e66663 LC |
901 | (define *core-package-modules* |
902 | (scheme-node "guix-packages-base" | |
eaae07ec | 903 | `((gnu packages) |
f2e66663 | 904 | (gnu packages base)) |
eaae07ec LC |
905 | (list *core-modules* *extra-modules*) |
906 | #:extensions dependencies | |
f2e66663 LC |
907 | |
908 | ;; Add all the non-Scheme files here. We must do it here so | |
909 | ;; that 'search-patches' & co. can find them. Ideally we'd | |
910 | ;; keep them next to the .scm files that use them but it's | |
911 | ;; difficult to do (XXX). | |
912 | #:extra-files | |
eaae07ec LC |
913 | (file-imports source "gnu/packages" |
914 | (lambda (file stat) | |
915 | (and (eq? 'regular (stat:type stat)) | |
916 | (not (string-suffix? ".scm" file)) | |
917 | (not (string-suffix? ".go" file)) | |
918 | (not (string-prefix? ".#" file)) | |
919 | (not (string-suffix? "~" file))))) | |
920 | #:guile-for-build guile-for-build)) | |
921 | ||
f2e66663 LC |
922 | (define *package-modules* |
923 | (scheme-node "guix-packages" | |
924 | (scheme-modules* source "gnu/packages") | |
925 | (list *core-modules* *extra-modules* *core-package-modules*) | |
926 | #:extensions dependencies | |
927 | #:guile-for-build guile-for-build)) | |
928 | ||
eaae07ec LC |
929 | (define *system-modules* |
930 | (scheme-node "guix-system" | |
931 | `((gnu system) | |
932 | (gnu services) | |
5a6e04c5 | 933 | ,@(scheme-modules* source "gnu/bootloader") |
a49d633c | 934 | ,@(scheme-modules* source "gnu/system") |
079c93e1 MW |
935 | ,@(scheme-modules* source "gnu/services") |
936 | ,@(scheme-modules* source "gnu/machine")) | |
f2e66663 LC |
937 | (list *core-package-modules* *package-modules* |
938 | *extra-modules* *core-modules*) | |
eaae07ec LC |
939 | #:extensions dependencies |
940 | #:extra-files | |
1458f768 LC |
941 | (append (file-imports source "gnu/system/examples" |
942 | (const #t)) | |
8bb62ae1 | 943 | |
a49d633c MO |
944 | ;; All the installer code is on the build-side. |
945 | (file-imports source "gnu/installer/" | |
946 | (const #t)) | |
1458f768 LC |
947 | ;; Build-side code that we don't build. Some of |
948 | ;; these depend on guile-rsvg, the Shepherd, etc. | |
949 | (file-imports source "gnu/build" (const #t))) | |
eaae07ec LC |
950 | #:guile-for-build |
951 | guile-for-build)) | |
952 | ||
953 | (define *cli-modules* | |
954 | (scheme-node "guix-cli" | |
b5f8c2c8 LC |
955 | (append (scheme-modules* source "/guix/scripts") |
956 | `((gnu ci))) | |
f2e66663 LC |
957 | (list *core-modules* *extra-modules* |
958 | *core-package-modules* *package-modules* | |
eaae07ec LC |
959 | *system-modules*) |
960 | #:extensions dependencies | |
961 | #:guile-for-build guile-for-build)) | |
962 | ||
5f2daffe LC |
963 | (define *system-test-modules* |
964 | ;; Ship these modules mostly so (gnu ci) can discover them. | |
965 | (scheme-node "guix-system-tests" | |
966 | `((gnu tests) | |
967 | ,@(scheme-modules* source "gnu/tests")) | |
968 | (list *core-package-modules* *package-modules* | |
969 | *extra-modules* *system-modules* *core-modules* | |
970 | *cli-modules*) ;for (guix scripts pack), etc. | |
971 | #:extensions dependencies | |
972 | #:guile-for-build guile-for-build)) | |
973 | ||
eaae07ec LC |
974 | (define *config* |
975 | (scheme-node "guix-config" | |
976 | '() | |
977 | #:extra-modules | |
978 | `(((guix config) | |
4c0c65ac | 979 | => ,(make-config.scm #:gzip gzip |
eaae07ec LC |
980 | #:bzip2 bzip2 |
981 | #:xz xz | |
eaae07ec LC |
982 | #:package-name |
983 | %guix-package-name | |
984 | #:package-version | |
985 | version | |
316fc2ac LC |
986 | #:channel-metadata |
987 | channel-metadata | |
eaae07ec LC |
988 | #:bug-report-address |
989 | %guix-bug-report-address | |
990 | #:home-page-url | |
991 | %guix-home-page-url))) | |
992 | #:guile-for-build guile-for-build)) | |
993 | ||
a89faa3f | 994 | (define (built-modules node-subset) |
8a0d9bc8 | 995 | (directory-union (string-append name "-modules") |
a89faa3f | 996 | (append-map node-subset |
8a0d9bc8 LC |
997 | |
998 | ;; Note: *CONFIG* comes first so that it | |
999 | ;; overrides the (guix config) module that | |
1000 | ;; comes with *CORE-MODULES*. | |
1001 | (list *config* | |
1002 | *cli-modules* | |
54800977 | 1003 | *system-test-modules* |
8a0d9bc8 LC |
1004 | *system-modules* |
1005 | *package-modules* | |
1006 | *core-package-modules* | |
1007 | *extra-modules* | |
1008 | *core-modules*)) | |
1009 | ||
1010 | ;; Silently choose the first entry upon collision so that | |
1011 | ;; we choose *CONFIG*. | |
1012 | #:resolve-collision 'first | |
1013 | ||
1014 | ;; When we do (add-to-store "utils.scm"), "utils.scm" must | |
1015 | ;; be a regular file, not a symlink. Thus, arrange so that | |
1016 | ;; regular files appear as regular files in the final | |
1017 | ;; output. | |
1018 | #:copy? #t | |
1019 | #:quiet? #t)) | |
1020 | ||
1021 | ;; Version 0 of 'guix pull' meant we'd just return Scheme modules. | |
1022 | ;; Version 1 is when we return the full package. | |
1023 | (cond ((= 1 pull-version) | |
1024 | ;; The whole package, with a standard file hierarchy. | |
49c35bbb LC |
1025 | (let* ((modules (built-modules (compose list node-source+compiled))) |
1026 | (command (guix-command modules | |
a89faa3f LC |
1027 | #:source source |
1028 | #:dependencies dependencies | |
8970a886 | 1029 | #:guile guile-for-build |
a89faa3f LC |
1030 | #:guile-version guile-version))) |
1031 | (whole-package name modules dependencies | |
9f1c3559 | 1032 | #:command command |
8970a886 | 1033 | #:guile guile-for-build |
baed9236 LC |
1034 | |
1035 | ;; Include 'guix-daemon'. XXX: Here we inject an | |
1036 | ;; older snapshot of guix-daemon, but that's a good | |
1037 | ;; enough approximation for now. | |
1038 | #:daemon (module-ref (resolve-interface | |
1039 | '(gnu packages | |
1040 | package-management)) | |
1041 | 'guix-daemon) | |
1042 | ||
4554d4c8 | 1043 | #:info (info-manual source) |
e3744779 | 1044 | #:miscellany (miscellaneous-files source) |
9f1c3559 | 1045 | #:guile-version guile-version))) |
8a0d9bc8 | 1046 | ((= 0 pull-version) |
a89faa3f LC |
1047 | ;; Legacy 'guix pull': return the .scm and .go files as one |
1048 | ;; directory. | |
1049 | (built-modules (lambda (node) | |
1050 | (list (node-source node) | |
1051 | (node-compiled node))))) | |
8a0d9bc8 LC |
1052 | (else |
1053 | ;; Unsupported 'guix pull' version. | |
1054 | #f))) | |
eaae07ec LC |
1055 | |
1056 | \f | |
1057 | ;;; | |
1058 | ;;; Generating (guix config). | |
1059 | ;;; | |
1060 | ||
eaae07ec LC |
1061 | (define %persona-variables |
1062 | ;; (guix config) variables that define Guix's persona. | |
1063 | '(%guix-package-name | |
1064 | %guix-version | |
1065 | %guix-bug-report-address | |
1066 | %guix-home-page-url)) | |
1067 | ||
1068 | (define %config-variables | |
45779fa6 LC |
1069 | ;; (guix config) variables corresponding to Guix configuration. |
1070 | (letrec-syntax ((variables (syntax-rules () | |
1071 | ((_) | |
1072 | '()) | |
1073 | ((_ variable rest ...) | |
1074 | (cons `(variable . ,variable) | |
1075 | (variables rest ...)))))) | |
54eadc42 | 1076 | (variables %localstatedir %storedir %sysconfdir))) |
eaae07ec | 1077 | |
4c0c65ac | 1078 | (define* (make-config.scm #:key gzip xz bzip2 |
eaae07ec LC |
1079 | (package-name "GNU Guix") |
1080 | (package-version "0") | |
316fc2ac | 1081 | (channel-metadata #f) |
eaae07ec | 1082 | (bug-report-address "bug-guix@gnu.org") |
3fb3291e | 1083 | (home-page-url "https://guix.gnu.org")) |
eaae07ec LC |
1084 | |
1085 | ;; Hack so that Geiser is not confused. | |
1086 | (define defmod 'define-module) | |
1087 | ||
1088 | (scheme-file "config.scm" | |
eb72cdf0 | 1089 | #~(;; The following expressions get spliced. |
eaae07ec LC |
1090 | (#$defmod (guix config) |
1091 | #:export (%guix-package-name | |
1092 | %guix-version | |
1093 | %guix-bug-report-address | |
1094 | %guix-home-page-url | |
316fc2ac | 1095 | %channel-metadata |
54eadc42 | 1096 | %system |
7af5c2a2 LC |
1097 | %store-directory |
1098 | %state-directory | |
1099 | %store-database-directory | |
1100 | %config-directory | |
eaae07ec LC |
1101 | %gzip |
1102 | %bzip2 | |
e8cb9c01 | 1103 | %xz)) |
eaae07ec | 1104 | |
54eadc42 LC |
1105 | (define %system |
1106 | #$(%current-system)) | |
1107 | ||
63cab418 LC |
1108 | #$@(map (match-lambda |
1109 | ((name . value) | |
1110 | #~(define-public #$name #$value))) | |
1111 | %config-variables) | |
1112 | ||
7af5c2a2 LC |
1113 | (define %store-directory |
1114 | (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path) | |
1115 | %storedir)) | |
1116 | ||
1117 | (define %state-directory | |
1118 | ;; This must match `NIX_STATE_DIR' as defined in | |
1119 | ;; `nix/local.mk'. | |
a87d66f3 | 1120 | (or (getenv "GUIX_STATE_DIRECTORY") |
7af5c2a2 LC |
1121 | (string-append %localstatedir "/guix"))) |
1122 | ||
1123 | (define %store-database-directory | |
a87d66f3 | 1124 | (or (getenv "GUIX_DATABASE_DIRECTORY") |
7af5c2a2 LC |
1125 | (string-append %state-directory "/db"))) |
1126 | ||
1127 | (define %config-directory | |
1128 | ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as | |
1129 | ;; defined in `nix/local.mk'. | |
1130 | (or (getenv "GUIX_CONFIGURATION_DIRECTORY") | |
1131 | (string-append %sysconfdir "/guix"))) | |
1132 | ||
63cab418 LC |
1133 | (define %guix-package-name #$package-name) |
1134 | (define %guix-version #$package-version) | |
1135 | (define %guix-bug-report-address #$bug-report-address) | |
1136 | (define %guix-home-page-url #$home-page-url) | |
1137 | ||
316fc2ac LC |
1138 | (define %channel-metadata |
1139 | ;; Metadata for the 'guix' channel in use. This | |
1140 | ;; information is used by (guix describe). | |
1141 | '#$channel-metadata) | |
1142 | ||
63cab418 LC |
1143 | (define %gzip |
1144 | #+(and gzip (file-append gzip "/bin/gzip"))) | |
1145 | (define %bzip2 | |
1146 | #+(and bzip2 (file-append bzip2 "/bin/bzip2"))) | |
1147 | (define %xz | |
4c0c65ac | 1148 | #+(and xz (file-append xz "/bin/xz")))) |
eb72cdf0 LC |
1149 | |
1150 | ;; Guile 2.0 *requires* the 'define-module' to be at the | |
e8cb9c01 | 1151 | ;; top-level or the 'toplevel-ref' in the resulting .go file are |
eb72cdf0 LC |
1152 | ;; made relative to a nonexistent anonymous module. |
1153 | #:splice? #t)) | |
eaae07ec | 1154 | |
eaae07ec LC |
1155 | \f |
1156 | ;;; | |
1157 | ;;; Building. | |
1158 | ;;; | |
1159 | ||
8031b3fa | 1160 | (define* (compiled-modules name module-tree module-files |
eaae07ec LC |
1161 | #:optional |
1162 | (dependencies '()) | |
1163 | (dependencies-compiled '()) | |
1164 | #:key | |
1165 | (extensions '()) ;full-blown Guile packages | |
1166 | parallel? | |
1167 | guile-for-build) | |
8031b3fa LC |
1168 | "Build all the MODULE-FILES from MODULE-TREE. MODULE-FILES must be a list |
1169 | like '(\"guix/foo.scm\" \"gnu/bar.scm\") and MODULE-TREE is the directory | |
1170 | containing MODULE-FILES and possibly other files as well." | |
eaae07ec LC |
1171 | ;; This is a non-monadic, enhanced version of 'compiled-file' from (guix |
1172 | ;; gexp). | |
1173 | (define build | |
1174 | (with-imported-modules (source-module-closure | |
1175 | '((guix build compile) | |
1176 | (guix build utils))) | |
1177 | #~(begin | |
1178 | (use-modules (srfi srfi-26) | |
1179 | (ice-9 match) | |
1180 | (ice-9 format) | |
1181 | (ice-9 threads) | |
1182 | (guix build compile) | |
1183 | (guix build utils)) | |
1184 | ||
1185 | (define (regular? file) | |
1186 | (not (member file '("." "..")))) | |
1187 | ||
1188 | (define (report-load file total completed) | |
1189 | (display #\cr) | |
1190 | (format #t | |
35dcaa11 LC |
1191 | "[~3@a/~3@a] loading...\t~5,1f% of ~d files" |
1192 | ||
1193 | ;; Note: Multiply TOTAL by two to account for the | |
1194 | ;; compilation phase that follows. | |
1195 | completed (* total 2) | |
1196 | ||
eaae07ec LC |
1197 | (* 100. (/ completed total)) total) |
1198 | (force-output)) | |
1199 | ||
1200 | (define (report-compilation file total completed) | |
1201 | (display #\cr) | |
35dcaa11 LC |
1202 | (format #t "[~3@a/~3@a] compiling...\t~5,1f% of ~d files" |
1203 | ||
1204 | ;; Add TOTAL to account for the load phase that came | |
1205 | ;; before. | |
1206 | (+ total completed) (* total 2) | |
1207 | ||
eaae07ec LC |
1208 | (* 100. (/ completed total)) total) |
1209 | (force-output)) | |
1210 | ||
8031b3fa LC |
1211 | (define (process-directory directory files output) |
1212 | ;; Hide compilation warnings. | |
1213 | (parameterize ((current-warning-port (%make-void-port "w"))) | |
1214 | (compile-files directory #$output files | |
1215 | #:workers (parallel-job-count) | |
1216 | #:report-load report-load | |
1217 | #:report-compilation report-compilation))) | |
eaae07ec | 1218 | |
35dcaa11 LC |
1219 | (setvbuf (current-output-port) 'line) |
1220 | (setvbuf (current-error-port) 'line) | |
eaae07ec LC |
1221 | |
1222 | (set! %load-path (cons #+module-tree %load-path)) | |
1223 | (set! %load-path | |
1224 | (append '#+dependencies | |
1225 | (map (lambda (extension) | |
1226 | (string-append extension "/share/guile/site/" | |
1227 | (effective-version))) | |
1228 | '#+extensions) | |
1229 | %load-path)) | |
1230 | ||
1231 | (set! %load-compiled-path | |
1232 | (append '#+dependencies-compiled | |
1233 | (map (lambda (extension) | |
1234 | (string-append extension "/lib/guile/" | |
1235 | (effective-version) | |
1236 | "/site-ccache")) | |
1237 | '#+extensions) | |
1238 | %load-compiled-path)) | |
1239 | ||
1240 | ;; Load the compiler modules upfront. | |
1241 | (compile #f) | |
1242 | ||
1243 | (mkdir #$output) | |
1244 | (chdir #+module-tree) | |
8031b3fa | 1245 | (process-directory "." '#+module-files #$output) |
69447b63 | 1246 | (newline)))) |
eaae07ec LC |
1247 | |
1248 | (computed-file name build | |
1249 | #:guile guile-for-build | |
1250 | #:options | |
1251 | `(#:local-build? #f ;allow substitutes | |
1252 | ||
1253 | ;; Don't annoy people about _IONBF deprecation. | |
54be2b4d LC |
1254 | ;; Initialize 'terminal-width' in (system repl debug) |
1255 | ;; to a large-enough value to make backtrace more | |
1256 | ;; verbose. | |
1257 | #:env-vars (("GUILE_WARN_DEPRECATED" . "no") | |
1258 | ("COLUMNS" . "200"))))) | |
eaae07ec LC |
1259 | |
1260 | \f | |
1261 | ;;; | |
1262 | ;;; Building. | |
1263 | ;;; | |
1264 | ||
eaae07ec | 1265 | (define* (guix-derivation source version |
8a0d9bc8 | 1266 | #:optional (guile-version (effective-version)) |
316fc2ac LC |
1267 | #:key (pull-version 0) |
1268 | channel-metadata) | |
eaae07ec | 1269 | "Return, as a monadic value, the derivation to build the Guix from SOURCE |
316fc2ac LC |
1270 | for GUILE-VERSION. Use VERSION as the version string. Use CHANNEL-METADATA |
1271 | as the channel metadata sexp to include in (guix config). | |
1272 | ||
1273 | PULL-VERSION specifies the version of the 'guix pull' protocol. Return #f if | |
1274 | this PULL-VERSION value is not supported." | |
eaae07ec LC |
1275 | (define (shorten version) |
1276 | (if (and (string-every char-set:hex-digit version) | |
1277 | (> (string-length version) 9)) | |
1278 | (string-take version 9) ;Git commit | |
1279 | version)) | |
1280 | ||
1281 | (define guile | |
8234fe65 LC |
1282 | ;; When PULL-VERSION >= 1, produce a self-contained Guix and use the |
1283 | ;; current Guile unconditionally. | |
1284 | (specification->package "guile")) | |
6e54e488 LC |
1285 | |
1286 | (when (and (< pull-version 1) | |
1287 | (not (string=? (package-version guile) guile-version))) | |
1288 | ;; Guix < 0.15.0 has PULL-VERSION = 0, where the host Guile is reused and | |
1289 | ;; can be any version. When that happens and Guile is not current (e.g., | |
1290 | ;; it's Guile 2.0), just bail out. | |
1291 | (raise (condition | |
1292 | (&message | |
1293 | (message "Guix is too old and cannot be upgraded"))))) | |
eaae07ec LC |
1294 | |
1295 | (mbegin %store-monad | |
1296 | (set-guile-for-build guile) | |
8a0d9bc8 LC |
1297 | (let ((guix (compiled-guix source |
1298 | #:version version | |
316fc2ac | 1299 | #:channel-metadata channel-metadata |
8a0d9bc8 LC |
1300 | #:name (string-append "guix-" |
1301 | (shorten version)) | |
1302 | #:pull-version pull-version | |
099bb017 | 1303 | #:guile-version (if (>= pull-version 1) |
8234fe65 | 1304 | "3.0" guile-version) |
8a0d9bc8 LC |
1305 | #:guile-for-build guile))) |
1306 | (if guix | |
1307 | (lower-object guix) | |
1308 | (return #f))))) |