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