Commit | Line | Data |
---|---|---|
eaae07ec LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix self) | |
20 | #:use-module (guix config) | |
21 | #:use-module (guix i18n) | |
22 | #:use-module (guix modules) | |
23 | #:use-module (guix gexp) | |
24 | #:use-module (guix store) | |
25 | #:use-module (guix monads) | |
26 | #:use-module (guix discovery) | |
27 | #:use-module (guix packages) | |
28 | #:use-module (guix sets) | |
29 | #:use-module (guix utils) | |
30 | #:use-module (guix modules) | |
31 | #:use-module (guix build utils) | |
32 | #:use-module ((guix build compile) #:select (%lightweight-optimizations)) | |
33 | #:use-module (srfi srfi-1) | |
34 | #:use-module (srfi srfi-9) | |
35 | #:use-module (ice-9 match) | |
36 | #:export (make-config.scm | |
37 | compiled-guix | |
38 | guix-derivation | |
39 | reload-guix)) | |
40 | ||
41 | \f | |
42 | ;;; | |
43 | ;;; Dependency handling. | |
44 | ;;; | |
45 | ||
46 | (define* (false-if-wrong-guile package | |
47 | #:optional (guile-version (effective-version))) | |
48 | "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g., | |
49 | 2.0 instead of 2.2), otherwise return PACKAGE." | |
50 | (let ((guile (any (match-lambda | |
51 | ((label (? package? dep) _ ...) | |
52 | (and (string=? (package-name dep) "guile") | |
53 | dep))) | |
54 | (package-direct-inputs package)))) | |
55 | (and (or (not guile) | |
56 | (string-prefix? guile-version | |
57 | (package-version guile))) | |
58 | package))) | |
59 | ||
60 | (define (package-for-guile guile-version . names) | |
61 | "Return the package with one of the given NAMES that depends on | |
62 | GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." | |
63 | (let loop ((names names)) | |
64 | (match names | |
65 | (() | |
66 | #f) | |
67 | ((name rest ...) | |
68 | (match (specification->package name) | |
69 | (#f | |
70 | (loop rest)) | |
71 | ((? package? package) | |
a1639ae9 | 72 | (or (false-if-wrong-guile package guile-version) |
eaae07ec LC |
73 | (loop rest)))))))) |
74 | ||
75 | (define specification->package | |
76 | ;; Use our own variant of that procedure because that of (gnu packages) | |
77 | ;; would traverse all the .scm files, which is wasteful. | |
78 | (let ((ref (lambda (module variable) | |
79 | (module-ref (resolve-interface module) variable)))) | |
80 | (match-lambda | |
81 | ("guile" (ref '(gnu packages commencement) 'guile-final)) | |
82 | ("guile-json" (ref '(gnu packages guile) 'guile-json)) | |
83 | ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) | |
84 | ("guile-git" (ref '(gnu packages guile) 'guile-git)) | |
6d52844c | 85 | ("guile-gdbm-ffi" (ref '(gnu packages guile) 'guile-gdbm-ffi)) |
d59e75f3 | 86 | ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) |
eaae07ec LC |
87 | ("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt)) |
88 | ("zlib" (ref '(gnu packages compression) 'zlib)) | |
89 | ("gzip" (ref '(gnu packages compression) 'gzip)) | |
90 | ("bzip2" (ref '(gnu packages compression) 'bzip2)) | |
91 | ("xz" (ref '(gnu packages compression) 'xz)) | |
92 | ("guix" (ref '(gnu packages package-management) | |
e69dd844 LC |
93 | 'guix-register)) |
94 | ("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json)) | |
95 | ("guile2.0-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh)) | |
96 | ("guile2.0-git" (ref '(gnu packages guile) 'guile2.0-git)) | |
6d52844c | 97 | ("guile2.0-gdbm-ffi" (ref '(gnu packages guile) 'guile2.0-gdbm-ffi)) |
d59e75f3 | 98 | ;; XXX: No "guile2.0-sqlite3". |
e69dd844 | 99 | (_ #f)))) ;no such package |
eaae07ec LC |
100 | |
101 | \f | |
102 | ;;; | |
103 | ;;; Derivations. | |
104 | ;;; | |
105 | ||
106 | ;; Node in a DAG of build tasks. Each node maps to a derivation, but it's | |
107 | ;; easier to express things this way. | |
108 | (define-record-type <node> | |
109 | (node name modules source dependencies compiled) | |
110 | node? | |
111 | (name node-name) ;string | |
112 | (modules node-modules) ;list of module names | |
113 | (source node-source) ;list of source files | |
114 | (dependencies node-dependencies) ;list of nodes | |
115 | (compiled node-compiled)) ;node -> lowerable object | |
116 | ||
117 | (define (node-fold proc init nodes) | |
118 | (let loop ((nodes nodes) | |
119 | (visited (setq)) | |
120 | (result init)) | |
121 | (match nodes | |
122 | (() result) | |
123 | ((head tail ...) | |
124 | (if (set-contains? visited head) | |
125 | (loop tail visited result) | |
126 | (loop tail (set-insert head visited) | |
127 | (proc head result))))))) | |
128 | ||
129 | (define (node-modules/recursive nodes) | |
130 | (node-fold (lambda (node modules) | |
131 | (append (node-modules node) modules)) | |
132 | '() | |
133 | nodes)) | |
134 | ||
135 | (define* (closure modules #:optional (except '())) | |
136 | (source-module-closure modules | |
137 | #:select? | |
138 | (match-lambda | |
139 | (('guix 'config) | |
140 | #f) | |
141 | ((and module | |
142 | (or ('guix _ ...) ('gnu _ ...))) | |
143 | (not (member module except))) | |
144 | (rest #f)))) | |
145 | ||
146 | (define module->import | |
147 | ;; Return a file-name/file-like object pair for the specified module and | |
148 | ;; suitable for 'imported-files'. | |
149 | (match-lambda | |
150 | ((module '=> thing) | |
151 | (let ((file (module-name->file-name module))) | |
152 | (list file thing))) | |
153 | (module | |
154 | (let ((file (module-name->file-name module))) | |
155 | (list file | |
156 | (local-file (search-path %load-path file))))))) | |
157 | ||
158 | (define* (scheme-node name modules #:optional (dependencies '()) | |
159 | #:key (extra-modules '()) (extra-files '()) | |
160 | (extensions '()) | |
161 | parallel? guile-for-build) | |
162 | "Return a node that builds the given Scheme MODULES, and depends on | |
163 | DEPENDENCIES (a list of nodes). EXTRA-MODULES is a list of additional modules | |
164 | added to the source, and EXTRA-FILES is a list of additional files. | |
165 | EXTENSIONS is a set of full-blown Guile packages (e.g., 'guile-json') that | |
166 | must be present in the search path." | |
167 | (let* ((modules (append extra-modules | |
168 | (closure modules | |
169 | (node-modules/recursive dependencies)))) | |
170 | (module-files (map module->import modules)) | |
171 | (source (imported-files (string-append name "-source") | |
172 | (append module-files extra-files)))) | |
173 | (node name modules source dependencies | |
8031b3fa LC |
174 | (compiled-modules name source |
175 | (map car module-files) | |
eaae07ec LC |
176 | (map node-source dependencies) |
177 | (map node-compiled dependencies) | |
178 | #:extensions extensions | |
179 | #:parallel? parallel? | |
180 | #:guile-for-build guile-for-build)))) | |
181 | ||
182 | (define (file-imports directory sub-directory pred) | |
183 | "List all the files matching PRED under DIRECTORY/SUB-DIRECTORY. Return a | |
184 | list of file-name/file-like objects suitable as inputs to 'imported-files'." | |
185 | (map (lambda (file) | |
186 | (list (string-drop file (+ 1 (string-length directory))) | |
187 | (local-file file #:recursive? #t))) | |
188 | (find-files (string-append directory "/" sub-directory) pred))) | |
189 | ||
190 | (define (scheme-modules* directory sub-directory) | |
191 | "Return the list of module names found under SUB-DIRECTORY in DIRECTORY." | |
192 | (let ((prefix (string-length directory))) | |
193 | (map (lambda (file) | |
194 | (file-name->module-name (string-drop file prefix))) | |
195 | (scheme-files (string-append directory "/" sub-directory))))) | |
196 | ||
197 | (define* (compiled-guix source #:key (version %guix-version) | |
198 | (name (string-append "guix-" version)) | |
199 | (guile-version (effective-version)) | |
200 | (guile-for-build (guile-for-build guile-version)) | |
201 | (libgcrypt (specification->package "libgcrypt")) | |
202 | (zlib (specification->package "zlib")) | |
203 | (gzip (specification->package "gzip")) | |
204 | (bzip2 (specification->package "bzip2")) | |
205 | (xz (specification->package "xz")) | |
206 | (guix (specification->package "guix"))) | |
207 | "Return a file-like object that contains a compiled Guix." | |
208 | (define guile-json | |
209 | (package-for-guile guile-version | |
210 | "guile-json" | |
eaae07ec LC |
211 | "guile2.0-json")) |
212 | ||
213 | (define guile-ssh | |
214 | (package-for-guile guile-version | |
215 | "guile-ssh" | |
eaae07ec LC |
216 | "guile2.0-ssh")) |
217 | ||
218 | (define guile-git | |
219 | (package-for-guile guile-version | |
220 | "guile-git" | |
221 | "guile2.0-git")) | |
222 | ||
6d52844c LC |
223 | (define guile-gdbm-ffi |
224 | (package-for-guile guile-version | |
225 | "guile-gdbm-ffi" | |
226 | "guile2.0-gdbm-ffi")) | |
227 | ||
eaae07ec | 228 | |
d59e75f3 LC |
229 | (define guile-sqlite3 |
230 | (package-for-guile guile-version | |
231 | "guile-sqlite3" | |
232 | "guile2.0-sqlite3")) | |
233 | ||
eaae07ec LC |
234 | (define dependencies |
235 | (match (append-map (lambda (package) | |
236 | (cons (list "x" package) | |
e13240f5 | 237 | (package-transitive-propagated-inputs package))) |
6d52844c LC |
238 | (list guile-git guile-json guile-ssh |
239 | guile-gdbm-ffi guile-sqlite3)) | |
eaae07ec LC |
240 | (((labels packages _ ...) ...) |
241 | packages))) | |
242 | ||
243 | (define *core-modules* | |
244 | (scheme-node "guix-core" | |
245 | '((guix) | |
246 | (guix monad-repl) | |
247 | (guix packages) | |
248 | (guix download) | |
249 | (guix discovery) | |
250 | (guix profiles) | |
251 | (guix build-system gnu) | |
252 | (guix build-system trivial) | |
253 | (guix build profiles) | |
254 | (guix build gnu-build-system)) | |
255 | ||
256 | ;; Provide a dummy (guix config) with the default version | |
257 | ;; number, storedir, etc. This is so that "guix-core" is the | |
258 | ;; same across all installations and doesn't need to be | |
259 | ;; rebuilt when the version changes, which in turn means we | |
260 | ;; can have substitutes for it. | |
261 | #:extra-modules | |
262 | `(((guix config) | |
263 | => ,(make-config.scm #:libgcrypt | |
264 | (specification->package | |
265 | "libgcrypt")))) | |
266 | ||
267 | #:guile-for-build guile-for-build)) | |
268 | ||
269 | (define *extra-modules* | |
270 | (scheme-node "guix-extra" | |
271 | (filter-map (match-lambda | |
272 | (('guix 'scripts _ ..1) #f) | |
273 | (name name)) | |
274 | (scheme-modules* source "guix")) | |
275 | (list *core-modules*) | |
276 | #:extensions dependencies | |
277 | #:guile-for-build guile-for-build)) | |
278 | ||
f2e66663 LC |
279 | (define *core-package-modules* |
280 | (scheme-node "guix-packages-base" | |
eaae07ec | 281 | `((gnu packages) |
f2e66663 | 282 | (gnu packages base)) |
eaae07ec LC |
283 | (list *core-modules* *extra-modules*) |
284 | #:extensions dependencies | |
f2e66663 LC |
285 | |
286 | ;; Add all the non-Scheme files here. We must do it here so | |
287 | ;; that 'search-patches' & co. can find them. Ideally we'd | |
288 | ;; keep them next to the .scm files that use them but it's | |
289 | ;; difficult to do (XXX). | |
290 | #:extra-files | |
eaae07ec LC |
291 | (file-imports source "gnu/packages" |
292 | (lambda (file stat) | |
293 | (and (eq? 'regular (stat:type stat)) | |
294 | (not (string-suffix? ".scm" file)) | |
295 | (not (string-suffix? ".go" file)) | |
296 | (not (string-prefix? ".#" file)) | |
297 | (not (string-suffix? "~" file))))) | |
298 | #:guile-for-build guile-for-build)) | |
299 | ||
f2e66663 LC |
300 | (define *package-modules* |
301 | (scheme-node "guix-packages" | |
302 | (scheme-modules* source "gnu/packages") | |
303 | (list *core-modules* *extra-modules* *core-package-modules*) | |
304 | #:extensions dependencies | |
305 | #:guile-for-build guile-for-build)) | |
306 | ||
eaae07ec LC |
307 | (define *system-modules* |
308 | (scheme-node "guix-system" | |
309 | `((gnu system) | |
310 | (gnu services) | |
311 | ,@(scheme-modules* source "gnu/system") | |
312 | ,@(scheme-modules* source "gnu/services")) | |
f2e66663 LC |
313 | (list *core-package-modules* *package-modules* |
314 | *extra-modules* *core-modules*) | |
eaae07ec LC |
315 | #:extensions dependencies |
316 | #:extra-files | |
1458f768 LC |
317 | (append (file-imports source "gnu/system/examples" |
318 | (const #t)) | |
319 | ||
320 | ;; Build-side code that we don't build. Some of | |
321 | ;; these depend on guile-rsvg, the Shepherd, etc. | |
322 | (file-imports source "gnu/build" (const #t))) | |
eaae07ec LC |
323 | #:guile-for-build |
324 | guile-for-build)) | |
325 | ||
326 | (define *cli-modules* | |
327 | (scheme-node "guix-cli" | |
328 | (scheme-modules* source "/guix/scripts") | |
f2e66663 LC |
329 | (list *core-modules* *extra-modules* |
330 | *core-package-modules* *package-modules* | |
eaae07ec LC |
331 | *system-modules*) |
332 | #:extensions dependencies | |
333 | #:guile-for-build guile-for-build)) | |
334 | ||
335 | (define *config* | |
336 | (scheme-node "guix-config" | |
337 | '() | |
338 | #:extra-modules | |
339 | `(((guix config) | |
340 | => ,(make-config.scm #:libgcrypt libgcrypt | |
341 | #:zlib zlib | |
342 | #:gzip gzip | |
343 | #:bzip2 bzip2 | |
344 | #:xz xz | |
345 | #:guix guix | |
346 | #:package-name | |
347 | %guix-package-name | |
348 | #:package-version | |
349 | version | |
350 | #:bug-report-address | |
351 | %guix-bug-report-address | |
352 | #:home-page-url | |
353 | %guix-home-page-url))) | |
354 | #:guile-for-build guile-for-build)) | |
355 | ||
356 | (directory-union name | |
357 | (append-map (lambda (node) | |
358 | (list (node-source node) | |
359 | (node-compiled node))) | |
360 | ||
361 | ;; Note: *CONFIG* comes first so that it | |
362 | ;; overrides the (guix config) module that | |
363 | ;; comes with *CORE-MODULES*. | |
364 | (list *config* | |
365 | *cli-modules* | |
366 | *system-modules* | |
367 | *package-modules* | |
f2e66663 | 368 | *core-package-modules* |
eaae07ec LC |
369 | *extra-modules* |
370 | *core-modules*)) | |
371 | ||
372 | ;; Silently choose the first entry upon collision so that | |
373 | ;; we choose *CONFIG*. | |
374 | #:resolve-collision 'first | |
375 | ||
376 | ;; When we do (add-to-store "utils.scm"), "utils.scm" must | |
377 | ;; be a regular file, not a symlink. Thus, arrange so that | |
378 | ;; regular files appear as regular files in the final | |
379 | ;; output. | |
380 | #:copy? #t | |
381 | #:quiet? #t)) | |
382 | ||
383 | \f | |
384 | ;;; | |
385 | ;;; Generating (guix config). | |
386 | ;;; | |
387 | ||
388 | (define %dependency-variables | |
389 | ;; (guix config) variables corresponding to dependencies. | |
390 | '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate | |
391 | %sbindir %guix-register-program)) | |
392 | ||
393 | (define %persona-variables | |
394 | ;; (guix config) variables that define Guix's persona. | |
395 | '(%guix-package-name | |
396 | %guix-version | |
397 | %guix-bug-report-address | |
398 | %guix-home-page-url)) | |
399 | ||
400 | (define %config-variables | |
401 | ;; (guix config) variables corresponding to Guix configuration (storedir, | |
402 | ;; localstatedir, etc.) | |
403 | (sort (filter pair? | |
404 | (module-map (lambda (name var) | |
405 | (and (not (memq name %dependency-variables)) | |
406 | (not (memq name %persona-variables)) | |
407 | (cons name (variable-ref var)))) | |
408 | (resolve-interface '(guix config)))) | |
409 | (lambda (name+value1 name+value2) | |
410 | (string<? (symbol->string (car name+value1)) | |
411 | (symbol->string (car name+value2)))))) | |
412 | ||
413 | (define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 guix | |
414 | (package-name "GNU Guix") | |
415 | (package-version "0") | |
416 | (bug-report-address "bug-guix@gnu.org") | |
417 | (home-page-url "https://gnu.org/s/guix")) | |
418 | ||
419 | ;; Hack so that Geiser is not confused. | |
420 | (define defmod 'define-module) | |
421 | ||
422 | (scheme-file "config.scm" | |
eb72cdf0 | 423 | #~(;; The following expressions get spliced. |
eaae07ec LC |
424 | (#$defmod (guix config) |
425 | #:export (%guix-package-name | |
426 | %guix-version | |
427 | %guix-bug-report-address | |
428 | %guix-home-page-url | |
429 | %sbindir | |
806ff358 | 430 | %guix-register-program |
eaae07ec LC |
431 | %libgcrypt |
432 | %libz | |
433 | %gzip | |
434 | %bzip2 | |
435 | %xz | |
436 | %nix-instantiate)) | |
437 | ||
63cab418 LC |
438 | #$@(map (match-lambda |
439 | ((name . value) | |
440 | #~(define-public #$name #$value))) | |
441 | %config-variables) | |
442 | ||
443 | (define %guix-package-name #$package-name) | |
444 | (define %guix-version #$package-version) | |
445 | (define %guix-bug-report-address #$bug-report-address) | |
446 | (define %guix-home-page-url #$home-page-url) | |
447 | ||
448 | (define %sbindir | |
449 | ;; This is used to define '%guix-register-program'. | |
450 | ;; TODO: Use a derivation that builds nothing but the | |
451 | ;; C++ part. | |
452 | #+(and guix (file-append guix "/sbin"))) | |
453 | ||
454 | (define %guix-register-program | |
455 | (or (getenv "GUIX_REGISTER") | |
456 | (and %sbindir | |
457 | (string-append %sbindir "/guix-register")))) | |
458 | ||
459 | (define %gzip | |
460 | #+(and gzip (file-append gzip "/bin/gzip"))) | |
461 | (define %bzip2 | |
462 | #+(and bzip2 (file-append bzip2 "/bin/bzip2"))) | |
463 | (define %xz | |
464 | #+(and xz (file-append xz "/bin/xz"))) | |
465 | ||
466 | (define %libgcrypt | |
467 | #+(and libgcrypt | |
468 | (file-append libgcrypt "/lib/libgcrypt"))) | |
469 | (define %libz | |
470 | #+(and zlib | |
471 | (file-append zlib "/lib/libz"))) | |
472 | ||
473 | (define %nix-instantiate ;for (guix import snix) | |
eb72cdf0 LC |
474 | "nix-instantiate")) |
475 | ||
476 | ;; Guile 2.0 *requires* the 'define-module' to be at the | |
477 | ;; top-level or it 'toplevel-ref' in the resulting .go file are | |
478 | ;; made relative to a nonexistent anonymous module. | |
479 | #:splice? #t)) | |
eaae07ec LC |
480 | |
481 | ||
482 | \f | |
483 | ;;; | |
484 | ;;; Building. | |
485 | ;;; | |
486 | ||
487 | (define (imported-files name files) | |
488 | ;; This is a non-monadic, simplified version of 'imported-files' from (guix | |
489 | ;; gexp). | |
1458f768 LC |
490 | (define same-target? |
491 | (match-lambda* | |
492 | (((file1 . _) (file2 . _)) | |
493 | (string=? file1 file2)))) | |
494 | ||
eaae07ec LC |
495 | (define build |
496 | (with-imported-modules (source-module-closure | |
497 | '((guix build utils))) | |
498 | #~(begin | |
499 | (use-modules (ice-9 match) | |
500 | (guix build utils)) | |
501 | ||
502 | (mkdir (ungexp output)) (chdir (ungexp output)) | |
503 | (for-each (match-lambda | |
504 | ((final-path store-path) | |
505 | (mkdir-p (dirname final-path)) | |
506 | ||
507 | ;; Note: We need regular files to be regular files, not | |
508 | ;; symlinks, as this makes a difference for | |
509 | ;; 'add-to-store'. | |
510 | (copy-file store-path final-path))) | |
1458f768 | 511 | '#$(delete-duplicates files same-target?))))) |
eaae07ec | 512 | |
14b392a8 LC |
513 | ;; We're just copying files around, no need to substitute or offload it. |
514 | (computed-file name build | |
515 | #:options '(#:local-build? #t | |
e3a87d77 LC |
516 | #:substitutable? #f |
517 | #:env-vars (("COLUMNS" . "200"))))) | |
eaae07ec | 518 | |
8031b3fa | 519 | (define* (compiled-modules name module-tree module-files |
eaae07ec LC |
520 | #:optional |
521 | (dependencies '()) | |
522 | (dependencies-compiled '()) | |
523 | #:key | |
524 | (extensions '()) ;full-blown Guile packages | |
525 | parallel? | |
526 | guile-for-build) | |
8031b3fa LC |
527 | "Build all the MODULE-FILES from MODULE-TREE. MODULE-FILES must be a list |
528 | like '(\"guix/foo.scm\" \"gnu/bar.scm\") and MODULE-TREE is the directory | |
529 | containing MODULE-FILES and possibly other files as well." | |
eaae07ec LC |
530 | ;; This is a non-monadic, enhanced version of 'compiled-file' from (guix |
531 | ;; gexp). | |
532 | (define build | |
533 | (with-imported-modules (source-module-closure | |
534 | '((guix build compile) | |
535 | (guix build utils))) | |
536 | #~(begin | |
537 | (use-modules (srfi srfi-26) | |
538 | (ice-9 match) | |
539 | (ice-9 format) | |
540 | (ice-9 threads) | |
541 | (guix build compile) | |
542 | (guix build utils)) | |
543 | ||
544 | (define (regular? file) | |
545 | (not (member file '("." "..")))) | |
546 | ||
547 | (define (report-load file total completed) | |
548 | (display #\cr) | |
549 | (format #t | |
550 | "loading...\t~5,1f% of ~d files" ;FIXME: i18n | |
551 | (* 100. (/ completed total)) total) | |
552 | (force-output)) | |
553 | ||
554 | (define (report-compilation file total completed) | |
555 | (display #\cr) | |
556 | (format #t "compiling...\t~5,1f% of ~d files" ;FIXME: i18n | |
557 | (* 100. (/ completed total)) total) | |
558 | (force-output)) | |
559 | ||
8031b3fa LC |
560 | (define (process-directory directory files output) |
561 | ;; Hide compilation warnings. | |
562 | (parameterize ((current-warning-port (%make-void-port "w"))) | |
563 | (compile-files directory #$output files | |
564 | #:workers (parallel-job-count) | |
565 | #:report-load report-load | |
566 | #:report-compilation report-compilation))) | |
eaae07ec LC |
567 | |
568 | (setvbuf (current-output-port) _IONBF) | |
569 | (setvbuf (current-error-port) _IONBF) | |
570 | ||
571 | (set! %load-path (cons #+module-tree %load-path)) | |
572 | (set! %load-path | |
573 | (append '#+dependencies | |
574 | (map (lambda (extension) | |
575 | (string-append extension "/share/guile/site/" | |
576 | (effective-version))) | |
577 | '#+extensions) | |
578 | %load-path)) | |
579 | ||
580 | (set! %load-compiled-path | |
581 | (append '#+dependencies-compiled | |
582 | (map (lambda (extension) | |
583 | (string-append extension "/lib/guile/" | |
584 | (effective-version) | |
585 | "/site-ccache")) | |
586 | '#+extensions) | |
587 | %load-compiled-path)) | |
588 | ||
589 | ;; Load the compiler modules upfront. | |
590 | (compile #f) | |
591 | ||
592 | (mkdir #$output) | |
593 | (chdir #+module-tree) | |
8031b3fa | 594 | (process-directory "." '#+module-files #$output) |
69447b63 | 595 | (newline)))) |
eaae07ec LC |
596 | |
597 | (computed-file name build | |
598 | #:guile guile-for-build | |
599 | #:options | |
600 | `(#:local-build? #f ;allow substitutes | |
601 | ||
602 | ;; Don't annoy people about _IONBF deprecation. | |
54be2b4d LC |
603 | ;; Initialize 'terminal-width' in (system repl debug) |
604 | ;; to a large-enough value to make backtrace more | |
605 | ;; verbose. | |
606 | #:env-vars (("GUILE_WARN_DEPRECATED" . "no") | |
607 | ("COLUMNS" . "200"))))) | |
eaae07ec LC |
608 | |
609 | \f | |
610 | ;;; | |
611 | ;;; Building. | |
612 | ;;; | |
613 | ||
614 | (define (guile-for-build version) | |
615 | "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently | |
616 | running Guile." | |
617 | (define canonical-package ;soft reference | |
618 | (module-ref (resolve-interface '(gnu packages base)) | |
619 | 'canonical-package)) | |
620 | ||
621 | (match version | |
622 | ("2.2.2" | |
623 | ;; Gross hack to avoid ABI incompatibilities (see | |
624 | ;; <https://bugs.gnu.org/29570>.) | |
625 | (module-ref (resolve-interface '(gnu packages guile)) | |
626 | 'guile-2.2.2)) | |
627 | ("2.2" | |
628 | (canonical-package (module-ref (resolve-interface '(gnu packages guile)) | |
629 | 'guile-2.2/fixed))) | |
630 | ("2.0" | |
e69dd844 LC |
631 | (module-ref (resolve-interface '(gnu packages guile)) |
632 | 'guile-2.0)))) | |
eaae07ec LC |
633 | |
634 | (define* (guix-derivation source version | |
635 | #:optional (guile-version (effective-version))) | |
636 | "Return, as a monadic value, the derivation to build the Guix from SOURCE | |
637 | for GUILE-VERSION. Use VERSION as the version string." | |
638 | (define (shorten version) | |
639 | (if (and (string-every char-set:hex-digit version) | |
640 | (> (string-length version) 9)) | |
641 | (string-take version 9) ;Git commit | |
642 | version)) | |
643 | ||
644 | (define guile | |
645 | (guile-for-build guile-version)) | |
646 | ||
647 | (mbegin %store-monad | |
648 | (set-guile-for-build guile) | |
649 | (lower-object (compiled-guix source | |
650 | #:version version | |
651 | #:name (string-append "guix-" | |
652 | (shorten version)) | |
653 | #:guile-version (match guile-version | |
654 | ("2.2.2" "2.2") | |
655 | (version version)) | |
656 | #:guile-for-build guile)))) |