Commit | Line | Data |
---|---|---|
21b679f6 | 1 | ;;; GNU Guix --- Functional package management for GNU |
bde7929b | 2 | ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
bdcf0e6f | 3 | ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> |
e8e1f295 | 4 | ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org> |
a6bf7a97 | 5 | ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com> |
a02ad459 | 6 | ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> |
21b679f6 LC |
7 | ;;; |
8 | ;;; This file is part of GNU Guix. | |
9 | ;;; | |
10 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
11 | ;;; under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
13 | ;;; your option) any later version. | |
14 | ;;; | |
15 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
19 | ;;; | |
20 | ;;; You should have received a copy of the GNU General Public License | |
21 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
22 | ||
23 | (define-module (guix gexp) | |
e87f0591 | 24 | #:use-module (guix store) |
21b679f6 | 25 | #:use-module (guix monads) |
e87f0591 | 26 | #:use-module (guix derivations) |
7adf9b84 | 27 | #:use-module (guix grafts) |
aa72d9af | 28 | #:use-module (guix utils) |
f43ffee9 LC |
29 | #:use-module (guix diagnostics) |
30 | #:use-module (guix i18n) | |
e8e1f295 | 31 | #:use-module (rnrs bytevectors) |
21b679f6 LC |
32 | #:use-module (srfi srfi-1) |
33 | #:use-module (srfi srfi-9) | |
7560b00b | 34 | #:use-module (srfi srfi-9 gnu) |
21b679f6 | 35 | #:use-module (srfi srfi-26) |
3e43166f LC |
36 | #:use-module (srfi srfi-34) |
37 | #:use-module (srfi srfi-35) | |
ca465a9c | 38 | #:use-module (ice-9 format) |
21b679f6 LC |
39 | #:use-module (ice-9 match) |
40 | #:export (gexp | |
41 | gexp? | |
0bb9929e | 42 | with-imported-modules |
838e17d8 | 43 | with-extensions |
644cb40c | 44 | let-system |
0dbea56b LC |
45 | |
46 | gexp-input | |
47 | gexp-input? | |
2ca41030 LC |
48 | gexp-input-thing |
49 | gexp-input-output | |
50 | gexp-input-native? | |
558e8b11 | 51 | |
5d4ad8e1 | 52 | assume-valid-file-name |
d9ae938f LC |
53 | local-file |
54 | local-file? | |
74d441ab | 55 | local-file-file |
9d3994f7 | 56 | local-file-absolute-file-name |
74d441ab LC |
57 | local-file-name |
58 | local-file-recursive? | |
f408d8d6 | 59 | local-file-select? |
0dbea56b | 60 | |
558e8b11 LC |
61 | plain-file |
62 | plain-file? | |
63 | plain-file-name | |
64 | plain-file-content | |
65 | ||
91937029 LC |
66 | computed-file |
67 | computed-file? | |
68 | computed-file-name | |
69 | computed-file-gexp | |
91937029 LC |
70 | computed-file-options |
71 | ||
15a01c72 LC |
72 | program-file |
73 | program-file? | |
74 | program-file-name | |
75 | program-file-gexp | |
15a01c72 | 76 | program-file-guile |
427ec19e | 77 | program-file-module-path |
15a01c72 | 78 | |
e1c153e0 LC |
79 | scheme-file |
80 | scheme-file? | |
81 | scheme-file-name | |
82 | scheme-file-gexp | |
83 | ||
a9e5e92f LC |
84 | file-append |
85 | file-append? | |
86 | file-append-base | |
87 | file-append-suffix | |
88 | ||
d63ee94d LC |
89 | raw-derivation-file |
90 | raw-derivation-file? | |
91 | ||
cf2ac04f LC |
92 | with-parameters |
93 | parameterized? | |
94 | ||
64fc9f65 RJ |
95 | load-path-expression |
96 | gexp-modules | |
97 | ||
2ca41030 LC |
98 | lower-gexp |
99 | lowered-gexp? | |
100 | lowered-gexp-sexp | |
101 | lowered-gexp-inputs | |
38685774 | 102 | lowered-gexp-sources |
2ca41030 LC |
103 | lowered-gexp-guile |
104 | lowered-gexp-load-path | |
105 | lowered-gexp-load-compiled-path | |
106 | ||
21b679f6 LC |
107 | gexp->derivation |
108 | gexp->file | |
462a3fa3 | 109 | gexp->script |
aa72d9af | 110 | text-file* |
b751cde3 | 111 | mixed-text-file |
dedb512f | 112 | file-union |
d298c815 | 113 | directory-union |
aa72d9af LC |
114 | imported-files |
115 | imported-modules | |
ff40e9b7 LC |
116 | compiled-modules |
117 | ||
118 | define-gexp-compiler | |
6b6298ae | 119 | gexp-compiler? |
bdcf0e6f | 120 | file-like? |
c2b84676 | 121 | lower-object |
6b6298ae | 122 | |
3e43166f LC |
123 | &gexp-error |
124 | gexp-error? | |
125 | &gexp-input-error | |
126 | gexp-input-error? | |
127 | gexp-error-invalid-input)) | |
21b679f6 LC |
128 | |
129 | ;;; Commentary: | |
130 | ;;; | |
131 | ;;; This module implements "G-expressions", or "gexps". Gexps are like | |
132 | ;;; S-expressions (sexps), with two differences: | |
133 | ;;; | |
134 | ;;; 1. References (un-quotations) to derivations or packages in a gexp are | |
667b2508 LC |
135 | ;;; replaced by the corresponding output file name; in addition, the |
136 | ;;; 'ungexp-native' unquote-like form allows code to explicitly refer to | |
137 | ;;; the native code of a given package, in case of cross-compilation; | |
21b679f6 LC |
138 | ;;; |
139 | ;;; 2. Gexps embed information about the derivations they refer to. | |
140 | ;;; | |
141 | ;;; Gexps make it easy to write to files Scheme code that refers to store | |
142 | ;;; items, or to write Scheme code to build derivations. | |
143 | ;;; | |
144 | ;;; Code: | |
145 | ||
146 | ;; "G expressions". | |
147 | (define-record-type <gexp> | |
18fc84bc | 148 | (make-gexp references modules extensions proc location) |
21b679f6 | 149 | gexp? |
affd7761 | 150 | (references gexp-references) ;list of <gexp-input> |
0bb9929e | 151 | (modules gexp-self-modules) ;list of module names |
838e17d8 | 152 | (extensions gexp-self-extensions) ;list of lowerable things |
18fc84bc LC |
153 | (proc gexp-proc) ;procedure |
154 | (location %gexp-location)) ;location alist | |
155 | ||
156 | (define (gexp-location gexp) | |
157 | "Return the source code location of GEXP." | |
158 | (and=> (%gexp-location gexp) source-properties->location)) | |
21b679f6 | 159 | |
7560b00b LC |
160 | (define (write-gexp gexp port) |
161 | "Write GEXP on PORT." | |
162 | (display "#<gexp " port) | |
2cf0ea0d LC |
163 | |
164 | ;; Try to write the underlying sexp. Now, this trick doesn't work when | |
165 | ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure | |
166 | ;; tries to use 'append' on that, which fails with wrong-type-arg. | |
167 | (false-if-exception | |
667b2508 | 168 | (write (apply (gexp-proc gexp) |
affd7761 | 169 | (gexp-references gexp)) |
667b2508 | 170 | port)) |
18fc84bc LC |
171 | |
172 | (let ((loc (gexp-location gexp))) | |
173 | (when loc | |
174 | (format port " ~a" (location->string loc)))) | |
175 | ||
7560b00b LC |
176 | (format port " ~a>" |
177 | (number->string (object-address gexp) 16))) | |
178 | ||
179 | (set-record-type-printer! <gexp> write-gexp) | |
180 | ||
bcb13287 LC |
181 | \f |
182 | ;;; | |
183 | ;;; Methods. | |
184 | ;;; | |
185 | ||
186 | ;; Compiler for a type of objects that may be introduced in a gexp. | |
187 | (define-record-type <gexp-compiler> | |
1cdecf24 | 188 | (gexp-compiler type lower expand) |
bcb13287 | 189 | gexp-compiler? |
1cdecf24 | 190 | (type gexp-compiler-type) ;record type descriptor |
ebdfd776 | 191 | (lower gexp-compiler-lower) |
1cdecf24 | 192 | (expand gexp-compiler-expand)) ;#f | DRV -> sexp |
bcb13287 | 193 | |
3e43166f LC |
194 | (define-condition-type &gexp-error &error |
195 | gexp-error?) | |
196 | ||
197 | (define-condition-type &gexp-input-error &gexp-error | |
198 | gexp-input-error? | |
199 | (input gexp-error-invalid-input)) | |
200 | ||
201 | ||
bcb13287 | 202 | (define %gexp-compilers |
1cdecf24 LC |
203 | ;; 'eq?' mapping of record type descriptor to <gexp-compiler>. |
204 | (make-hash-table 20)) | |
bcb13287 | 205 | |
ebdfd776 LC |
206 | (define (default-expander thing obj output) |
207 | "This is the default expander for \"things\" that appear in gexps. It | |
208 | returns its output file name of OBJ's OUTPUT." | |
209 | (match obj | |
210 | ((? derivation? drv) | |
211 | (derivation->output-path drv output)) | |
212 | ((? string? file) | |
644cb40c LC |
213 | file) |
214 | ((? self-quoting? obj) | |
215 | obj))) | |
ebdfd776 | 216 | |
bcb13287 LC |
217 | (define (register-compiler! compiler) |
218 | "Register COMPILER as a gexp compiler." | |
1cdecf24 LC |
219 | (hashq-set! %gexp-compilers |
220 | (gexp-compiler-type compiler) compiler)) | |
bcb13287 LC |
221 | |
222 | (define (lookup-compiler object) | |
ebdfd776 | 223 | "Search for a compiler for OBJECT. Upon success, return the three argument |
bcb13287 | 224 | procedure to lower it; otherwise return #f." |
1cdecf24 LC |
225 | (and=> (hashq-ref %gexp-compilers (struct-vtable object)) |
226 | gexp-compiler-lower)) | |
bcb13287 | 227 | |
bdcf0e6f CL |
228 | (define (file-like? object) |
229 | "Return #t if OBJECT leads to a file in the store once unquoted in a | |
230 | G-expression; otherwise return #f." | |
231 | (and (struct? object) (->bool (lookup-compiler object)))) | |
232 | ||
ebdfd776 LC |
233 | (define (lookup-expander object) |
234 | "Search for an expander for OBJECT. Upon success, return the three argument | |
235 | procedure to expand it; otherwise return #f." | |
1cdecf24 LC |
236 | (and=> (hashq-ref %gexp-compilers (struct-vtable object)) |
237 | gexp-compiler-expand)) | |
ebdfd776 | 238 | |
c2b84676 LC |
239 | (define* (lower-object obj |
240 | #:optional (system (%current-system)) | |
a6bf7a97 | 241 | #:key (target 'current)) |
c2b84676 LC |
242 | "Return as a value in %STORE-MONAD the derivation or store item |
243 | corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true. | |
244 | OBJ must be an object that has an associated gexp compiler, such as a | |
245 | <package>." | |
d03001a3 LC |
246 | (mlet %store-monad ((target (if (eq? target 'current) |
247 | (current-target-system) | |
248 | (return target))) | |
249 | (graft? (grafting?))) | |
250 | (let loop ((obj obj)) | |
251 | (match (lookup-compiler obj) | |
252 | (#f | |
253 | (raise (condition (&gexp-input-error (input obj))))) | |
254 | (lower | |
255 | ;; Cache in STORE the result of lowering OBJ. | |
256 | (mcached (mlet %store-monad ((lowered (lower obj system target))) | |
257 | (if (and (struct? lowered) | |
258 | (not (derivation? lowered))) | |
259 | (loop lowered) | |
260 | (return lowered))) | |
261 | obj | |
262 | system target graft?)))))) | |
263 | ||
264 | (define* (lower+expand-object obj | |
265 | #:optional (system (%current-system)) | |
266 | #:key target (output "out")) | |
267 | "Return as a value in %STORE-MONAD the output of object OBJ expands to for | |
268 | SYSTEM and TARGET. Object such as <package>, <file-append>, or <plain-file> | |
269 | expand to file names, but it's possible to expand to a plain data type." | |
270 | (let loop ((obj obj) | |
271 | (expand (and (struct? obj) (lookup-expander obj)))) | |
272 | (match (lookup-compiler obj) | |
273 | (#f | |
274 | (raise (condition (&gexp-input-error (input obj))))) | |
275 | (lower | |
276 | (mlet* %store-monad ((graft? (grafting?)) | |
277 | (lowered (mcached (lower obj system target) | |
278 | obj | |
279 | system target graft?))) | |
280 | ;; LOWER might return something that needs to be further | |
281 | ;; lowered. | |
282 | (if (struct? lowered) | |
283 | ;; If we lack an expander, delegate to that of LOWERED. | |
284 | (if (not expand) | |
285 | (loop lowered (lookup-expander lowered)) | |
286 | (return (expand obj lowered output))) | |
abf43d45 LC |
287 | (if (not expand) ;self-quoting |
288 | (return lowered) | |
289 | (return (expand obj lowered output))))))))) | |
c2b84676 | 290 | |
ebdfd776 LC |
291 | (define-syntax define-gexp-compiler |
292 | (syntax-rules (=> compiler expander) | |
293 | "Define NAME as a compiler for objects matching PREDICATE encountered in | |
294 | gexps. | |
295 | ||
d03001a3 LC |
296 | In the simplest form of the macro, BODY must return (1) a derivation for |
297 | a record of the specified type, for SYSTEM and TARGET (the latter of which is | |
298 | #f except when cross-compiling), (2) another record that can itself be | |
299 | compiled down to a derivation, or (3) an object of a primitive data type. | |
ebdfd776 LC |
300 | |
301 | The more elaborate form allows you to specify an expander: | |
302 | ||
d03001a3 | 303 | (define-gexp-compiler something-compiler <something> |
ebdfd776 LC |
304 | compiler => (lambda (param system target) ...) |
305 | expander => (lambda (param drv output) ...)) | |
306 | ||
307 | The expander specifies how an object is converted to its sexp representation." | |
1cdecf24 LC |
308 | ((_ (name (param record-type) system target) body ...) |
309 | (define-gexp-compiler name record-type | |
ebdfd776 LC |
310 | compiler => (lambda (param system target) body ...) |
311 | expander => default-expander)) | |
1cdecf24 | 312 | ((_ name record-type |
ebdfd776 LC |
313 | compiler => compile |
314 | expander => expand) | |
315 | (begin | |
316 | (define name | |
1cdecf24 | 317 | (gexp-compiler record-type compile expand)) |
ebdfd776 | 318 | (register-compiler! name))))) |
bcb13287 | 319 | |
1cdecf24 | 320 | (define-gexp-compiler (derivation-compiler (drv <derivation>) system target) |
2924f0d6 LC |
321 | ;; Derivations are the lowest-level representation, so this is the identity |
322 | ;; compiler. | |
323 | (with-monad %store-monad | |
324 | (return drv))) | |
325 | ||
d63ee94d LC |
326 | ;; Expand to a raw ".drv" file for the lowerable object it wraps. In other |
327 | ;; words, this gives the raw ".drv" file instead of its build result. | |
328 | (define-record-type <raw-derivation-file> | |
329 | (raw-derivation-file obj) | |
330 | raw-derivation-file? | |
331 | (obj raw-derivation-file-object)) ;lowerable object | |
332 | ||
333 | (define-gexp-compiler raw-derivation-file-compiler <raw-derivation-file> | |
334 | compiler => (lambda (obj system target) | |
335 | (mlet %store-monad ((obj (lower-object | |
336 | (raw-derivation-file-object obj) | |
337 | system #:target target))) | |
338 | ;; Returning the .drv file name instead of the <derivation> | |
339 | ;; record ensures that 'lower-gexp' will classify it as a | |
340 | ;; "source" and not as an "input". | |
341 | (return (if (derivation? obj) | |
342 | (derivation-file-name obj) | |
343 | obj)))) | |
344 | expander => (lambda (obj lowered output) | |
345 | (if (derivation? lowered) | |
346 | (derivation-file-name lowered) | |
347 | lowered))) | |
348 | ||
bcb13287 | 349 | \f |
644cb40c LC |
350 | ;;; |
351 | ;;; System dependencies. | |
352 | ;;; | |
353 | ||
354 | ;; Binding form for the current system and cross-compilation target. | |
355 | (define-record-type <system-binding> | |
356 | (system-binding proc) | |
357 | system-binding? | |
358 | (proc system-binding-proc)) | |
359 | ||
360 | (define-syntax let-system | |
361 | (syntax-rules () | |
362 | "Introduce a system binding in a gexp. The simplest form is: | |
363 | ||
364 | (let-system system | |
365 | (cond ((string=? system \"x86_64-linux\") ...) | |
366 | (else ...))) | |
367 | ||
368 | which binds SYSTEM to the currently targeted system. The second form is | |
369 | similar, but it also shows the cross-compilation target: | |
370 | ||
371 | (let-system (system target) | |
372 | ...) | |
373 | ||
374 | Here TARGET is bound to the cross-compilation triplet or #f." | |
375 | ((_ (system target) exp0 exp ...) | |
376 | (system-binding (lambda (system target) | |
377 | exp0 exp ...))) | |
378 | ((_ system exp0 exp ...) | |
379 | (system-binding (lambda (system target) | |
380 | exp0 exp ...))))) | |
381 | ||
382 | (define-gexp-compiler system-binding-compiler <system-binding> | |
383 | compiler => (lambda (binding system target) | |
384 | (match binding | |
385 | (($ <system-binding> proc) | |
386 | (with-monad %store-monad | |
387 | ;; PROC is expected to return a lowerable object. | |
388 | ;; 'lower-object' takes care of residualizing it to a | |
389 | ;; derivation or similar. | |
390 | (return (proc system target)))))) | |
391 | ||
392 | ;; Delegate to the expander of the object returned by PROC. | |
393 | expander => #f) | |
394 | ||
395 | \f | |
d9ae938f | 396 | ;;; |
558e8b11 | 397 | ;;; File declarations. |
d9ae938f LC |
398 | ;;; |
399 | ||
9d3994f7 LC |
400 | ;; A local file name. FILE is the file name the user entered, which can be a |
401 | ;; relative file name, and ABSOLUTE is a promise that computes its canonical | |
402 | ;; absolute file name. We keep it in a promise to compute it lazily and avoid | |
403 | ;; repeated 'stat' calls. | |
d9ae938f | 404 | (define-record-type <local-file> |
0687fc9c | 405 | (%%local-file file absolute name recursive? select?) |
d9ae938f LC |
406 | local-file? |
407 | (file local-file-file) ;string | |
9d3994f7 | 408 | (absolute %local-file-absolute-file-name) ;promise string |
d9ae938f | 409 | (name local-file-name) ;string |
0687fc9c LC |
410 | (recursive? local-file-recursive?) ;Boolean |
411 | (select? local-file-select?)) ;string stat -> Boolean | |
412 | ||
413 | (define (true file stat) #t) | |
d9ae938f | 414 | |
9d3994f7 | 415 | (define* (%local-file file promise #:optional (name (basename file)) |
f43ffee9 LC |
416 | #:key |
417 | (literal? #t) location | |
418 | recursive? (select? true)) | |
9d3994f7 LC |
419 | ;; This intermediate procedure is part of our ABI, but the underlying |
420 | ;; %%LOCAL-FILE is not. | |
f43ffee9 LC |
421 | (when (and (not literal?) (not (string-prefix? "/" file))) |
422 | (warning (and=> location source-properties->location) | |
423 | (G_ "resolving '~a' relative to current directory~%") | |
424 | file)) | |
0687fc9c | 425 | (%%local-file file promise name recursive? select?)) |
9d3994f7 | 426 | |
9d3994f7 LC |
427 | (define (absolute-file-name file directory) |
428 | "Return the canonical absolute file name for FILE, which lives in the | |
429 | vicinity of DIRECTORY." | |
430 | (canonicalize-path | |
431 | (cond ((string-prefix? "/" file) file) | |
432 | ((not directory) file) | |
433 | ((string-prefix? "/" directory) | |
434 | (string-append directory "/" file)) | |
435 | (else file)))) | |
436 | ||
5d4ad8e1 LC |
437 | (define-syntax-rule (assume-valid-file-name file) |
438 | "This is a syntactic keyword to tell 'local-file' that it can assume that | |
439 | the given file name is valid, even if it's not a string literal, and thus not | |
440 | warn about it." | |
441 | file) | |
442 | ||
302d46e6 LC |
443 | (define-syntax local-file |
444 | (lambda (s) | |
445 | "Return an object representing local file FILE to add to the store; this | |
9d3994f7 LC |
446 | object can be used in a gexp. If FILE is a relative file name, it is looked |
447 | up relative to the source file where this form appears. FILE will be added to | |
448 | the store under NAME--by default the base name of FILE. | |
d9ae938f LC |
449 | |
450 | When RECURSIVE? is true, the contents of FILE are added recursively; if FILE | |
451 | designates a flat file and RECURSIVE? is true, its contents are added, and its | |
452 | permission bits are kept. | |
453 | ||
0687fc9c LC |
454 | When RECURSIVE? is true, call (SELECT? FILE STAT) for each directory entry, |
455 | where FILE is the entry's absolute file name and STAT is the result of | |
456 | 'lstat'; exclude entries for which SELECT? does not return true. | |
457 | ||
302d46e6 LC |
458 | This is the declarative counterpart of the 'interned-file' monadic procedure. |
459 | It is implemented as a macro to capture the current source directory where it | |
460 | appears." | |
5d4ad8e1 | 461 | (syntax-case s (assume-valid-file-name) |
302d46e6 | 462 | ((_ file rest ...) |
99c45877 LC |
463 | (string? (syntax->datum #'file)) |
464 | ;; FILE is a literal, so resolve it relative to the source directory. | |
302d46e6 LC |
465 | #'(%local-file file |
466 | (delay (absolute-file-name file (current-source-directory))) | |
467 | rest ...)) | |
5d4ad8e1 | 468 | ((_ (assume-valid-file-name file) rest ...) |
6be71461 | 469 | ;; FILE is not a literal, so resolve it relative to the current |
5d4ad8e1 LC |
470 | ;; directory. Since the user declared FILE is valid, do not pass |
471 | ;; #:literal? #f so that we do not warn about it later on. | |
472 | #'(%local-file file | |
6be71461 | 473 | (delay (absolute-file-name file (getcwd))) |
5d4ad8e1 | 474 | rest ...)) |
99c45877 LC |
475 | ((_ file rest ...) |
476 | ;; Resolve FILE relative to the current directory. | |
f43ffee9 LC |
477 | (with-syntax ((location (datum->syntax s (syntax-source s)))) |
478 | #`(%local-file file | |
479 | (delay (absolute-file-name file (getcwd))) | |
9471aea7 | 480 | rest ... |
f43ffee9 | 481 | #:location 'location |
5d4ad8e1 | 482 | #:literal? #f))) ;warn if FILE is relative |
302d46e6 LC |
483 | ((_) |
484 | #'(syntax-error "missing file name")) | |
485 | (id | |
486 | (identifier? #'id) | |
487 | ;; XXX: We could return #'(lambda (file . rest) ...). However, | |
488 | ;; (syntax-source #'id) is #f so (current-source-directory) would not | |
489 | ;; work. Thus, simply forbid this form. | |
490 | #'(syntax-error | |
491 | "'local-file' is a macro and cannot be used like this"))))) | |
9d3994f7 LC |
492 | |
493 | (define (local-file-absolute-file-name file) | |
494 | "Return the absolute file name for FILE, a <local-file> instance. A | |
495 | 'system-error' exception is raised if FILE could not be found." | |
496 | (force (%local-file-absolute-file-name file))) | |
d9ae938f | 497 | |
1cdecf24 | 498 | (define-gexp-compiler (local-file-compiler (file <local-file>) system target) |
d9ae938f LC |
499 | ;; "Compile" FILE by adding it to the store. |
500 | (match file | |
0687fc9c | 501 | (($ <local-file> file (= force absolute) name recursive? select?) |
9d3994f7 LC |
502 | ;; Canonicalize FILE so that if it's a symlink, it is resolved. Failing |
503 | ;; to do that, when RECURSIVE? is #t, we could end up creating a dangling | |
504 | ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would | |
505 | ;; just throw an error, both of which are inconvenient. | |
0687fc9c LC |
506 | (interned-file absolute name |
507 | #:recursive? recursive? #:select? select?)))) | |
d9ae938f | 508 | |
558e8b11 LC |
509 | (define-record-type <plain-file> |
510 | (%plain-file name content references) | |
511 | plain-file? | |
512 | (name plain-file-name) ;string | |
e8e1f295 | 513 | (content plain-file-content) ;string or bytevector |
558e8b11 LC |
514 | (references plain-file-references)) ;list (currently unused) |
515 | ||
516 | (define (plain-file name content) | |
517 | "Return an object representing a text file called NAME with the given | |
518 | CONTENT (a string) to be added to the store. | |
519 | ||
520 | This is the declarative counterpart of 'text-file'." | |
521 | ;; XXX: For now just ignore 'references' because it's not clear how to use | |
522 | ;; them in a declarative context. | |
523 | (%plain-file name content '())) | |
524 | ||
1cdecf24 | 525 | (define-gexp-compiler (plain-file-compiler (file <plain-file>) system target) |
558e8b11 LC |
526 | ;; "Compile" FILE by adding it to the store. |
527 | (match file | |
e8e1f295 JN |
528 | (($ <plain-file> name (and (? string?) content) references) |
529 | (text-file name content references)) | |
530 | (($ <plain-file> name (and (? bytevector?) content) references) | |
531 | (binary-file name content references)))) | |
558e8b11 | 532 | |
91937029 | 533 | (define-record-type <computed-file> |
ab25eb7c | 534 | (%computed-file name gexp guile options) |
91937029 LC |
535 | computed-file? |
536 | (name computed-file-name) ;string | |
537 | (gexp computed-file-gexp) ;gexp | |
ab25eb7c | 538 | (guile computed-file-guile) ;<package> |
91937029 LC |
539 | (options computed-file-options)) ;list of arguments |
540 | ||
541 | (define* (computed-file name gexp | |
a02ad459 | 542 | #:key guile (local-build? #t) (options '())) |
91937029 | 543 | "Return an object representing the store item NAME, a file or directory |
a02ad459 MC |
544 | computed by GEXP. When LOCAL-BUILD? is #t (the default), it ensures the |
545 | corresponding derivation is built locally. OPTIONS may be used to pass | |
546 | additional arguments to 'gexp->derivation'. | |
91937029 LC |
547 | |
548 | This is the declarative counterpart of 'gexp->derivation'." | |
a02ad459 MC |
549 | (let ((options* `(#:local-build? ,local-build? ,@options))) |
550 | (%computed-file name gexp guile options*))) | |
91937029 | 551 | |
1cdecf24 | 552 | (define-gexp-compiler (computed-file-compiler (file <computed-file>) |
91937029 LC |
553 | system target) |
554 | ;; Compile FILE by returning a derivation whose build expression is its | |
555 | ;; gexp. | |
556 | (match file | |
ab25eb7c LC |
557 | (($ <computed-file> name gexp guile options) |
558 | (if guile | |
559 | (mlet %store-monad ((guile (lower-object guile system | |
560 | #:target target))) | |
561 | (apply gexp->derivation name gexp #:guile-for-build guile | |
9ec154f5 LC |
562 | #:system system #:target target options)) |
563 | (apply gexp->derivation name gexp | |
564 | #:system system #:target target options))))) | |
91937029 | 565 | |
15a01c72 | 566 | (define-record-type <program-file> |
427ec19e | 567 | (%program-file name gexp guile path) |
15a01c72 LC |
568 | program-file? |
569 | (name program-file-name) ;string | |
570 | (gexp program-file-gexp) ;gexp | |
427ec19e LC |
571 | (guile program-file-guile) ;package |
572 | (path program-file-module-path)) ;list of strings | |
15a01c72 | 573 | |
427ec19e | 574 | (define* (program-file name gexp #:key (guile #f) (module-path %load-path)) |
15a01c72 | 575 | "Return an object representing the executable store item NAME that runs |
427ec19e LC |
576 | GEXP. GUILE is the Guile package used to execute that script. Imported |
577 | modules of GEXP are looked up in MODULE-PATH. | |
15a01c72 LC |
578 | |
579 | This is the declarative counterpart of 'gexp->script'." | |
427ec19e | 580 | (%program-file name gexp guile module-path)) |
15a01c72 | 581 | |
1cdecf24 | 582 | (define-gexp-compiler (program-file-compiler (file <program-file>) |
15a01c72 LC |
583 | system target) |
584 | ;; Compile FILE by returning a derivation that builds the script. | |
585 | (match file | |
427ec19e | 586 | (($ <program-file> name gexp guile module-path) |
15a01c72 | 587 | (gexp->script name gexp |
427ec19e | 588 | #:module-path module-path |
2e8cabb8 LC |
589 | #:guile (or guile (default-guile)) |
590 | #:system system | |
591 | #:target target)))) | |
15a01c72 | 592 | |
e1c153e0 | 593 | (define-record-type <scheme-file> |
34faf63e | 594 | (%scheme-file name gexp splice? load-path?) |
e1c153e0 LC |
595 | scheme-file? |
596 | (name scheme-file-name) ;string | |
4fbd1a2b | 597 | (gexp scheme-file-gexp) ;gexp |
34faf63e LC |
598 | (splice? scheme-file-splice?) ;Boolean |
599 | (load-path? scheme-file-set-load-path?)) ;Boolean | |
e1c153e0 | 600 | |
34faf63e | 601 | (define* (scheme-file name gexp #:key splice? (set-load-path? #t)) |
e1c153e0 LC |
602 | "Return an object representing the Scheme file NAME that contains GEXP. |
603 | ||
604 | This is the declarative counterpart of 'gexp->file'." | |
34faf63e | 605 | (%scheme-file name gexp splice? set-load-path?)) |
e1c153e0 | 606 | |
1cdecf24 | 607 | (define-gexp-compiler (scheme-file-compiler (file <scheme-file>) |
e1c153e0 LC |
608 | system target) |
609 | ;; Compile FILE by returning a derivation that builds the file. | |
610 | (match file | |
34faf63e | 611 | (($ <scheme-file> name gexp splice? set-load-path?) |
3cd1444d | 612 | (gexp->file name gexp |
34faf63e | 613 | #:set-load-path? set-load-path? |
3cd1444d MO |
614 | #:splice? splice? |
615 | #:system system | |
616 | #:target target)))) | |
e1c153e0 | 617 | |
a9e5e92f LC |
618 | ;; Appending SUFFIX to BASE's output file name. |
619 | (define-record-type <file-append> | |
620 | (%file-append base suffix) | |
621 | file-append? | |
622 | (base file-append-base) ;<package> | <derivation> | ... | |
623 | (suffix file-append-suffix)) ;list of strings | |
624 | ||
39d7fdce LC |
625 | (define (write-file-append file port) |
626 | (match file | |
627 | (($ <file-append> base suffix) | |
628 | (format port "#<file-append ~s ~s>" base | |
629 | (string-join suffix))))) | |
630 | ||
631 | (set-record-type-printer! <file-append> write-file-append) | |
632 | ||
a9e5e92f LC |
633 | (define (file-append base . suffix) |
634 | "Return a <file-append> object that expands to the concatenation of BASE and | |
635 | SUFFIX." | |
636 | (%file-append base suffix)) | |
637 | ||
1cdecf24 | 638 | (define-gexp-compiler file-append-compiler <file-append> |
a9e5e92f LC |
639 | compiler => (lambda (obj system target) |
640 | (match obj | |
641 | (($ <file-append> base _) | |
642 | (lower-object base system #:target target)))) | |
643 | expander => (lambda (obj lowered output) | |
644 | (match obj | |
645 | (($ <file-append> base suffix) | |
646 | (let* ((expand (lookup-expander base)) | |
647 | (base (expand base lowered output))) | |
648 | (string-append base (string-concatenate suffix))))))) | |
649 | ||
cf2ac04f LC |
650 | ;; Representation of SRFI-39 parameter settings in the dynamic scope of an |
651 | ;; object lowering. | |
652 | (define-record-type <parameterized> | |
653 | (parameterized bindings thunk) | |
654 | parameterized? | |
655 | (bindings parameterized-bindings) ;list of parameter/value pairs | |
656 | (thunk parameterized-thunk)) ;thunk | |
657 | ||
658 | (define-syntax-rule (with-parameters ((param value) ...) body ...) | |
659 | "Bind each PARAM to the corresponding VALUE for the extent during which BODY | |
660 | is lowered. Consider this example: | |
661 | ||
662 | (with-parameters ((%current-system \"x86_64-linux\")) | |
663 | coreutils) | |
664 | ||
665 | It returns a <parameterized> object that ensures %CURRENT-SYSTEM is set to | |
666 | x86_64-linux when COREUTILS is lowered." | |
667 | (parameterized (list (list param (lambda () value)) ...) | |
668 | (lambda () | |
669 | body ...))) | |
670 | ||
671 | (define-gexp-compiler compile-parameterized <parameterized> | |
672 | compiler => | |
673 | (lambda (parameterized system target) | |
674 | (match (parameterized-bindings parameterized) | |
675 | (((parameters values) ...) | |
676 | (let ((fluids (map parameter-fluid parameters)) | |
677 | (thunk (parameterized-thunk parameterized))) | |
678 | ;; Install the PARAMETERS for the dynamic extent of THUNK. | |
679 | (with-fluids* fluids | |
680 | (map (lambda (thunk) (thunk)) values) | |
681 | (lambda () | |
682 | ;; Special-case '%current-system' and '%current-target-system' to | |
683 | ;; make sure we get the desired effect. | |
684 | (let ((system (if (memq %current-system parameters) | |
685 | (%current-system) | |
686 | system)) | |
687 | (target (if (memq %current-target-system parameters) | |
688 | (%current-target-system) | |
689 | target))) | |
690 | (lower-object (thunk) system #:target target)))))))) | |
691 | ||
692 | expander => (lambda (parameterized lowered output) | |
693 | (match (parameterized-bindings parameterized) | |
694 | (((parameters values) ...) | |
695 | (let ((fluids (map parameter-fluid parameters)) | |
696 | (thunk (parameterized-thunk parameterized))) | |
697 | ;; Install the PARAMETERS for the dynamic extent of THUNK. | |
698 | (with-fluids* fluids | |
699 | (map (lambda (thunk) (thunk)) values) | |
700 | (lambda () | |
701 | ;; Delegate to the expander of the wrapped object. | |
702 | (let* ((base (thunk)) | |
703 | (expand (lookup-expander base))) | |
704 | (expand base lowered output))))))))) | |
a9e5e92f | 705 | |
d9ae938f | 706 | \f |
bcb13287 LC |
707 | ;;; |
708 | ;;; Inputs & outputs. | |
709 | ;;; | |
710 | ||
e39d1461 LC |
711 | ;; The input of a gexp. |
712 | (define-record-type <gexp-input> | |
0dbea56b | 713 | (%gexp-input thing output native?) |
e39d1461 LC |
714 | gexp-input? |
715 | (thing gexp-input-thing) ;<package> | <origin> | <derivation> | ... | |
716 | (output gexp-input-output) ;string | |
717 | (native? gexp-input-native?)) ;Boolean | |
718 | ||
f7328634 LC |
719 | (define (write-gexp-input input port) |
720 | (match input | |
721 | (($ <gexp-input> thing output #f) | |
722 | (format port "#<gexp-input ~s:~a>" thing output)) | |
723 | (($ <gexp-input> thing output #t) | |
724 | (format port "#<gexp-input native ~s:~a>" thing output)))) | |
725 | ||
726 | (set-record-type-printer! <gexp-input> write-gexp-input) | |
727 | ||
0dbea56b LC |
728 | (define* (gexp-input thing ;convenience procedure |
729 | #:optional (output "out") | |
730 | #:key native?) | |
731 | "Return a new <gexp-input> for the OUTPUT of THING; NATIVE? determines | |
732 | whether this should be considered a \"native\" input or not." | |
733 | (%gexp-input thing output native?)) | |
734 | ||
21b679f6 LC |
735 | ;; Reference to one of the derivation's outputs, for gexps used in |
736 | ;; derivations. | |
1e87da58 LC |
737 | (define-record-type <gexp-output> |
738 | (gexp-output name) | |
739 | gexp-output? | |
740 | (name gexp-output-name)) | |
21b679f6 | 741 | |
f7328634 LC |
742 | (define (write-gexp-output output port) |
743 | (match output | |
744 | (($ <gexp-output> name) | |
745 | (format port "#<gexp-output ~a>" name)))) | |
746 | ||
747 | (set-record-type-printer! <gexp-output> write-gexp-output) | |
748 | ||
ca465a9c LC |
749 | (define* (gexp-attribute gexp self-attribute #:optional (equal? equal?) |
750 | #:key (validate (const #t))) | |
838e17d8 | 751 | "Recurse on GEXP and the expressions it refers to, summing the items |
932d1600 | 752 | returned by SELF-ATTRIBUTE, a procedure that takes a gexp. Use EQUAL? as the |
ca465a9c LC |
753 | second argument to 'delete-duplicates'. Pass VALIDATE every gexp and |
754 | attribute that is traversed." | |
2363bdd7 LC |
755 | (if (gexp? gexp) |
756 | (delete-duplicates | |
ca465a9c LC |
757 | (append (let ((attribute (self-attribute gexp))) |
758 | (validate gexp attribute) | |
759 | attribute) | |
fcde4e10 LC |
760 | (reverse |
761 | (fold (lambda (input result) | |
762 | (match input | |
763 | (($ <gexp-input> (? gexp? exp)) | |
764 | (append (gexp-attribute exp self-attribute | |
765 | #:validate validate) | |
766 | result)) | |
767 | (($ <gexp-input> (lst ...)) | |
768 | (fold/tree (lambda (obj result) | |
769 | (match obj | |
770 | ((? gexp? exp) | |
771 | (append (gexp-attribute exp self-attribute | |
772 | #:validate validate) | |
773 | result)) | |
774 | (_ | |
775 | result))) | |
776 | result | |
777 | lst)) | |
778 | (_ | |
779 | result))) | |
780 | '() | |
781 | (gexp-references gexp)))) | |
932d1600 | 782 | equal?) |
2363bdd7 | 783 | '())) ;plain Scheme data type |
0bb9929e | 784 | |
838e17d8 LC |
785 | (define (gexp-modules gexp) |
786 | "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is | |
787 | false, meaning that GEXP is a plain Scheme object, return the empty list." | |
932d1600 LC |
788 | (define (module=? m1 m2) |
789 | ;; Return #t when M1 equals M2. Special-case '=>' specs because their | |
790 | ;; right-hand side may not be comparable with 'equal?': it's typically a | |
791 | ;; file-like object that embeds a gexp, which in turn embeds closure; | |
792 | ;; those closures may be 'eq?' when running compiled code but are unlikely | |
793 | ;; to be 'eq?' when running on 'eval'. Ignore the right-hand side to | |
794 | ;; avoid this discrepancy. | |
795 | (match m1 | |
796 | (((name1 ...) '=> _) | |
797 | (match m2 | |
798 | (((name2 ...) '=> _) (equal? name1 name2)) | |
799 | (_ #f))) | |
800 | (_ | |
801 | (equal? m1 m2)))) | |
802 | ||
ca465a9c LC |
803 | (define (validate-modules gexp modules) |
804 | ;; Warn if MODULES, imported by GEXP, contains modules that in general | |
805 | ;; should not be imported from the host because they vary from user to | |
806 | ;; user and may thus be a source of non-reproducibility. This includes | |
807 | ;; (guix config) as well as modules that come with Guile. | |
808 | (match (filter (match-lambda | |
809 | ((or ('guix 'config) ('ice-9 . _)) #t) | |
810 | (_ #f)) | |
811 | modules) | |
812 | (() #t) | |
813 | (suspects | |
814 | (warning (gexp-location gexp) | |
815 | (N_ "importing module~{ ~a~} from the host~%" | |
816 | "importing modules~{ ~a~} from the host~%" | |
817 | (length suspects)) | |
818 | suspects)))) | |
819 | ||
820 | (gexp-attribute gexp gexp-self-modules module=? | |
821 | #:validate validate-modules)) | |
838e17d8 LC |
822 | |
823 | (define (gexp-extensions gexp) | |
824 | "Return the list of Guile extensions (packages) GEXP relies on. If (gexp? | |
825 | GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty | |
826 | list." | |
827 | (gexp-attribute gexp gexp-self-extensions)) | |
828 | ||
644cb40c LC |
829 | (define (self-quoting? x) |
830 | (letrec-syntax ((one-of (syntax-rules () | |
831 | ((_) #f) | |
832 | ((_ pred rest ...) | |
833 | (or (pred x) | |
834 | (one-of rest ...)))))) | |
835 | (one-of symbol? string? keyword? pair? null? array? | |
836 | number? boolean? char?))) | |
837 | ||
b57de6fe | 838 | (define (lower-inputs inputs system target) |
38685774 LC |
839 | "Turn any object from INPUTS into a derivation input for SYSTEM or a store |
840 | item (a \"source\"); return the corresponding input list as a monadic value. | |
841 | When TARGET is true, use it as the cross-compilation target triplet." | |
2ca41030 LC |
842 | (define (store-item? obj) |
843 | (and (string? obj) (store-path? obj))) | |
844 | ||
644cb40c LC |
845 | (define filterm |
846 | (lift1 (cut filter ->bool <>) %store-monad)) | |
847 | ||
21b679f6 | 848 | (with-monad %store-monad |
644cb40c LC |
849 | (>>= (mapm/accumulate-builds |
850 | (match-lambda | |
fc6d6aee LC |
851 | (($ <gexp-input> (? store-item? item)) |
852 | (return item)) | |
853 | (($ <gexp-input> thing output native?) | |
854 | (mlet %store-monad ((obj (lower-object thing system | |
855 | #:target | |
856 | (and (not native?) | |
857 | target)))) | |
644cb40c LC |
858 | (return (match obj |
859 | ((? derivation? drv) | |
fc6d6aee | 860 | (derivation-input drv (list output))) |
644cb40c LC |
861 | ((? store-item? item) |
862 | item) | |
863 | ((? self-quoting?) | |
864 | ;; Some inputs such as <system-binding> can lower to | |
865 | ;; a self-quoting object that FILTERM will filter | |
866 | ;; out. | |
fc6d6aee | 867 | #f)))))) |
644cb40c LC |
868 | inputs) |
869 | filterm))) | |
21b679f6 | 870 | |
b53833b2 LC |
871 | (define* (lower-reference-graphs graphs #:key system target) |
872 | "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a | |
873 | #:reference-graphs argument, lower it such that each INPUT is replaced by the | |
38685774 | 874 | corresponding <derivation-input> or store item." |
fc6d6aee LC |
875 | (define tuple->gexp-input |
876 | (match-lambda | |
877 | ((thing) | |
9fc4e949 | 878 | (%gexp-input thing "out" (not target))) |
fc6d6aee | 879 | ((thing output) |
9fc4e949 | 880 | (%gexp-input thing output (not target))))) |
fc6d6aee | 881 | |
b53833b2 LC |
882 | (match graphs |
883 | (((file-names . inputs) ...) | |
fc6d6aee | 884 | (mlet %store-monad ((inputs (lower-inputs (map tuple->gexp-input inputs) |
b57de6fe | 885 | system target))) |
38685774 | 886 | (return (map cons file-names inputs)))))) |
b53833b2 | 887 | |
c8351d9a LC |
888 | (define* (lower-references lst #:key system target) |
889 | "Based on LST, a list of output names and packages, return a list of output | |
890 | names and file names suitable for the #:allowed-references argument to | |
891 | 'derivation'." | |
c8351d9a LC |
892 | (with-monad %store-monad |
893 | (define lower | |
894 | (match-lambda | |
895 | ((? string? output) | |
896 | (return output)) | |
accb682c | 897 | (($ <gexp-input> thing output native?) |
c2b84676 LC |
898 | (mlet %store-monad ((drv (lower-object thing system |
899 | #:target (if native? | |
900 | #f target)))) | |
accb682c | 901 | (return (derivation->output-path drv output)))) |
bcb13287 | 902 | (thing |
c2b84676 LC |
903 | (mlet %store-monad ((drv (lower-object thing system |
904 | #:target target))) | |
c8351d9a LC |
905 | (return (derivation->output-path drv)))))) |
906 | ||
b34ead48 | 907 | (mapm/accumulate-builds lower lst))) |
c8351d9a | 908 | |
ff40e9b7 LC |
909 | (define default-guile-derivation |
910 | ;; Here we break the abstraction by talking to the higher-level layer. | |
911 | ;; Thus, do the resolution lazily to hide the circular dependency. | |
912 | (let ((proc (delay | |
913 | (let ((iface (resolve-interface '(guix packages)))) | |
914 | (module-ref iface 'default-guile-derivation))))) | |
915 | (lambda (system) | |
916 | ((force proc) system)))) | |
917 | ||
2ca41030 | 918 | ;; Representation of a gexp instantiated for a given target and system. |
38685774 | 919 | ;; It's an intermediate representation between <gexp> and <derivation>. |
2ca41030 | 920 | (define-record-type <lowered-gexp> |
38685774 | 921 | (lowered-gexp sexp inputs sources guile load-path load-compiled-path) |
2ca41030 LC |
922 | lowered-gexp? |
923 | (sexp lowered-gexp-sexp) ;sexp | |
38685774 LC |
924 | (inputs lowered-gexp-inputs) ;list of <derivation-input> |
925 | (sources lowered-gexp-sources) ;list of store items | |
b9373e26 | 926 | (guile lowered-gexp-guile) ;<derivation-input> | #f |
2ca41030 LC |
927 | (load-path lowered-gexp-load-path) ;list of store items |
928 | (load-compiled-path lowered-gexp-load-compiled-path)) ;list of store items | |
929 | ||
f58b4535 LC |
930 | (define* (imported+compiled-modules modules system |
931 | #:key (extensions '()) | |
932 | deprecation-warnings guile | |
933 | (module-path %load-path)) | |
934 | "Return a pair where the first element is the imported MODULES and the | |
935 | second element is the derivation to compile them." | |
f5fca9a8 LC |
936 | (mcached equal? |
937 | (mlet %store-monad ((modules (if (pair? modules) | |
938 | (imported-modules modules | |
3a5fbced | 939 | #:guile guile |
f5fca9a8 LC |
940 | #:system system |
941 | #:module-path module-path) | |
942 | (return #f))) | |
943 | (compiled (if (pair? modules) | |
944 | (compiled-modules modules | |
945 | #:system system | |
946 | #:module-path module-path | |
947 | #:extensions extensions | |
948 | #:guile guile | |
949 | #:deprecation-warnings | |
950 | deprecation-warnings) | |
951 | (return #f)))) | |
952 | (return (cons modules compiled))) | |
953 | modules | |
954 | system extensions guile deprecation-warnings module-path)) | |
f58b4535 | 955 | |
bde7929b LC |
956 | (define (sexp->string sexp) |
957 | "Like 'object->string', but deterministic and slightly faster." | |
958 | ;; Explicitly use UTF-8 for determinism, and also because UTF-8 output is | |
959 | ;; faster. | |
960 | (with-fluids ((%default-port-encoding "UTF-8")) | |
961 | (call-with-output-string | |
962 | (lambda (port) | |
963 | (write sexp port))))) | |
964 | ||
2ca41030 LC |
965 | (define* (lower-gexp exp |
966 | #:key | |
967 | (module-path %load-path) | |
968 | (system (%current-system)) | |
969 | (target 'current) | |
970 | (graft? (%graft?)) | |
971 | (guile-for-build (%guile-for-build)) | |
2bc1a400 | 972 | (effective-version "3.0") |
2ca41030 | 973 | |
fb9a23a3 | 974 | deprecation-warnings) |
2ca41030 LC |
975 | "*Note: This API is subject to change; use at your own risk!* |
976 | ||
977 | Lower EXP, a gexp, instantiating it for SYSTEM and TARGET. Return a | |
978 | <lowered-gexp> ready to be used. | |
979 | ||
980 | Lowered gexps are an intermediate representation that's useful for | |
981 | applications that deal with gexps outside in a way that is disconnected from | |
982 | derivations--e.g., code evaluated for its side effects." | |
983 | (define %modules | |
984 | (delete-duplicates (gexp-modules exp))) | |
985 | ||
986 | (define (search-path modules extensions suffix) | |
987 | (append (match modules | |
988 | ((? derivation? drv) | |
989 | (list (derivation->output-path drv))) | |
990 | (#f | |
991 | '()) | |
992 | ((? store-path? item) | |
993 | (list item))) | |
994 | (map (lambda (extension) | |
995 | (string-append (match extension | |
996 | ((? derivation? drv) | |
997 | (derivation->output-path drv)) | |
998 | ((? store-path? item) | |
999 | item)) | |
1000 | suffix)) | |
1001 | extensions))) | |
1002 | ||
1003 | (mlet* %store-monad ( ;; The following binding forces '%current-system' and | |
1004 | ;; '%current-target-system' to be looked up at >>= | |
1005 | ;; time. | |
1006 | (graft? (set-grafting graft?)) | |
1007 | ||
1008 | (system -> (or system (%current-system))) | |
1009 | (target -> (if (eq? target 'current) | |
1010 | (%current-target-system) | |
1011 | target)) | |
1012 | (guile (if guile-for-build | |
1013 | (return guile-for-build) | |
1014 | (default-guile-derivation system))) | |
4fa9d48f | 1015 | (inputs (lower-inputs (gexp-inputs exp) |
b57de6fe LC |
1016 | system target)) |
1017 | (sexp (gexp->sexp exp system target)) | |
2ca41030 LC |
1018 | (extensions -> (gexp-extensions exp)) |
1019 | (exts (mapm %store-monad | |
1020 | (lambda (obj) | |
a6bf7a97 MO |
1021 | (lower-object obj system |
1022 | #:target #f)) | |
2ca41030 | 1023 | extensions)) |
f58b4535 LC |
1024 | (modules+compiled (imported+compiled-modules |
1025 | %modules system | |
1026 | #:extensions extensions | |
1027 | #:deprecation-warnings | |
1028 | deprecation-warnings | |
1029 | #:guile guile | |
1030 | #:module-path module-path)) | |
1031 | (modules -> (car modules+compiled)) | |
1032 | (compiled -> (cdr modules+compiled))) | |
2ca41030 LC |
1033 | (define load-path |
1034 | (search-path modules exts | |
1035 | (string-append "/share/guile/site/" effective-version))) | |
1036 | ||
1037 | (define load-compiled-path | |
1038 | (search-path compiled exts | |
1039 | (string-append "/lib/guile/" effective-version | |
1040 | "/site-ccache"))) | |
1041 | ||
1042 | (mbegin %store-monad | |
1043 | (set-grafting graft?) ;restore the initial setting | |
1044 | (return (lowered-gexp sexp | |
38685774 LC |
1045 | `(,@(if (derivation? modules) |
1046 | (list (derivation-input modules)) | |
2ca41030 LC |
1047 | '()) |
1048 | ,@(if compiled | |
38685774 | 1049 | (list (derivation-input compiled)) |
2ca41030 | 1050 | '()) |
38685774 LC |
1051 | ,@(map derivation-input exts) |
1052 | ,@(filter derivation-input? inputs)) | |
1053 | (filter string? (cons modules inputs)) | |
b9373e26 | 1054 | (derivation-input guile '("out")) |
2ca41030 LC |
1055 | load-path |
1056 | load-compiled-path))))) | |
1057 | ||
21b679f6 LC |
1058 | (define* (gexp->derivation name exp |
1059 | #:key | |
68a61e9f | 1060 | system (target 'current) |
21b679f6 LC |
1061 | hash hash-algo recursive? |
1062 | (env-vars '()) | |
1063 | (modules '()) | |
4684f301 | 1064 | (module-path %load-path) |
21b679f6 | 1065 | (guile-for-build (%guile-for-build)) |
2bc1a400 | 1066 | (effective-version "3.0") |
ce45eb4c | 1067 | (graft? (%graft?)) |
21b679f6 | 1068 | references-graphs |
3f4ecf32 | 1069 | allowed-references disallowed-references |
c0468155 | 1070 | leaked-env-vars |
0309e1b0 | 1071 | local-build? (substitutable? #t) |
8856f409 | 1072 | (properties '()) |
a912c723 | 1073 | deprecation-warnings |
0309e1b0 | 1074 | (script-name (string-append name "-builder"))) |
21b679f6 | 1075 | "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a |
0309e1b0 LC |
1076 | derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME. When |
1077 | TARGET is true, it is used as the cross-compilation target triplet for | |
1078 | packages referred to by EXP. | |
21b679f6 | 1079 | |
0bb9929e LC |
1080 | MODULES is deprecated in favor of 'with-imported-modules'. Its meaning is to |
1081 | make MODULES available in the evaluation context of EXP; MODULES is a list of | |
4684f301 | 1082 | names of Guile modules searched in MODULE-PATH to be copied in the store, |
21b679f6 LC |
1083 | compiled, and made available in the load path during the execution of |
1084 | EXP---e.g., '((guix build utils) (guix build gnu-build-system)). | |
1085 | ||
838e17d8 LC |
1086 | EFFECTIVE-VERSION determines the string to use when adding extensions of |
1087 | EXP (see 'with-extensions') to the search path---e.g., \"2.2\". | |
1088 | ||
ce45eb4c LC |
1089 | GRAFT? determines whether packages referred to by EXP should be grafted when |
1090 | applicable. | |
1091 | ||
b53833b2 LC |
1092 | When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the |
1093 | following forms: | |
1094 | ||
1095 | (FILE-NAME PACKAGE) | |
1096 | (FILE-NAME PACKAGE OUTPUT) | |
1097 | (FILE-NAME DERIVATION) | |
1098 | (FILE-NAME DERIVATION OUTPUT) | |
1099 | (FILE-NAME STORE-ITEM) | |
1100 | ||
1101 | The right-hand-side of each element of REFERENCES-GRAPHS is automatically made | |
1102 | an input of the build process of EXP. In the build environment, each | |
1103 | FILE-NAME contains the reference graph of the corresponding item, in a simple | |
1104 | text format. | |
1105 | ||
c8351d9a LC |
1106 | ALLOWED-REFERENCES must be either #f or a list of output names and packages. |
1107 | In the latter case, the list denotes store items that the result is allowed to | |
1108 | refer to. Any reference to another store item will lead to a build error. | |
3f4ecf32 LC |
1109 | Similarly for DISALLOWED-REFERENCES, which can list items that must not be |
1110 | referenced by the outputs. | |
b53833b2 | 1111 | |
a912c723 LC |
1112 | DEPRECATION-WARNINGS determines whether to show deprecation warnings while |
1113 | compiling modules. It can be #f, #t, or 'detailed. | |
1114 | ||
21b679f6 | 1115 | The other arguments are as for 'derivation'." |
21b679f6 | 1116 | (define outputs (gexp-outputs exp)) |
2ca41030 | 1117 | (define requested-graft? graft?) |
21b679f6 | 1118 | |
b53833b2 LC |
1119 | (define (graphs-file-names graphs) |
1120 | ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS. | |
1121 | (map (match-lambda | |
38685774 LC |
1122 | ((file-name . (? derivation-input? input)) |
1123 | (cons file-name (first (derivation-input-output-paths input)))) | |
1124 | ((file-name . (? string? item)) | |
1125 | (cons file-name item))) | |
b53833b2 LC |
1126 | graphs)) |
1127 | ||
2ca41030 LC |
1128 | (define (add-modules exp modules) |
1129 | (if (null? modules) | |
1130 | exp | |
1131 | (make-gexp (gexp-references exp) | |
1132 | (append modules (gexp-self-modules exp)) | |
1133 | (gexp-self-extensions exp) | |
18fc84bc LC |
1134 | (gexp-proc exp) |
1135 | (gexp-location exp)))) | |
838e17d8 LC |
1136 | |
1137 | (mlet* %store-monad ( ;; The following binding forces '%current-system' and | |
ce45eb4c LC |
1138 | ;; '%current-target-system' to be looked up at >>= |
1139 | ;; time. | |
1140 | (graft? (set-grafting graft?)) | |
68a61e9f | 1141 | |
5d098459 | 1142 | (system -> (or system (%current-system))) |
68a61e9f LC |
1143 | (target -> (if (eq? target 'current) |
1144 | (%current-target-system) | |
1145 | target)) | |
2ca41030 LC |
1146 | (exp -> (add-modules exp modules)) |
1147 | (lowered (lower-gexp exp | |
1148 | #:module-path module-path | |
1149 | #:system system | |
1150 | #:target target | |
1151 | #:graft? requested-graft? | |
1152 | #:guile-for-build | |
1153 | guile-for-build | |
1154 | #:effective-version | |
1155 | effective-version | |
1156 | #:deprecation-warnings | |
fb9a23a3 | 1157 | deprecation-warnings)) |
2ca41030 | 1158 | |
b53833b2 LC |
1159 | (graphs (if references-graphs |
1160 | (lower-reference-graphs references-graphs | |
1161 | #:system system | |
1162 | #:target target) | |
1163 | (return #f))) | |
c8351d9a LC |
1164 | (allowed (if allowed-references |
1165 | (lower-references allowed-references | |
1166 | #:system system | |
1167 | #:target target) | |
1168 | (return #f))) | |
3f4ecf32 LC |
1169 | (disallowed (if disallowed-references |
1170 | (lower-references disallowed-references | |
1171 | #:system system | |
1172 | #:target target) | |
1173 | (return #f))) | |
2ca41030 LC |
1174 | (guile -> (lowered-gexp-guile lowered)) |
1175 | (builder (text-file script-name | |
bde7929b | 1176 | (sexp->string |
2ca41030 | 1177 | (lowered-gexp-sexp lowered))))) |
ce45eb4c LC |
1178 | (mbegin %store-monad |
1179 | (set-grafting graft?) ;restore the initial setting | |
1180 | (raw-derivation name | |
b9373e26 | 1181 | (string-append (derivation-input-output-path guile) |
ce45eb4c LC |
1182 | "/bin/guile") |
1183 | `("--no-auto-compile" | |
2ca41030 LC |
1184 | ,@(append-map (lambda (directory) |
1185 | `("-L" ,directory)) | |
1186 | (lowered-gexp-load-path lowered)) | |
1187 | ,@(append-map (lambda (directory) | |
1188 | `("-C" ,directory)) | |
1189 | (lowered-gexp-load-compiled-path lowered)) | |
ce45eb4c LC |
1190 | ,builder) |
1191 | #:outputs outputs | |
1192 | #:env-vars env-vars | |
1193 | #:system system | |
b9373e26 | 1194 | #:inputs `(,guile |
38685774 | 1195 | ,@(lowered-gexp-inputs lowered) |
ce45eb4c | 1196 | ,@(match graphs |
38685774 LC |
1197 | (((_ . inputs) ...) |
1198 | (filter derivation-input? inputs)) | |
1199 | (#f '()))) | |
1200 | #:sources `(,builder | |
1201 | ,@(if (and (string? modules) | |
1202 | (store-path? modules)) | |
1203 | (list modules) | |
1204 | '()) | |
1205 | ,@(lowered-gexp-sources lowered) | |
1206 | ,@(match graphs | |
1207 | (((_ . inputs) ...) | |
1208 | (filter string? inputs)) | |
1209 | (#f '()))) | |
1210 | ||
ce45eb4c LC |
1211 | #:hash hash #:hash-algo hash-algo #:recursive? recursive? |
1212 | #:references-graphs (and=> graphs graphs-file-names) | |
1213 | #:allowed-references allowed | |
3f4ecf32 | 1214 | #:disallowed-references disallowed |
c0468155 | 1215 | #:leaked-env-vars leaked-env-vars |
4a6aeb67 | 1216 | #:local-build? local-build? |
8856f409 LC |
1217 | #:substitutable? substitutable? |
1218 | #:properties properties)))) | |
21b679f6 | 1219 | |
c8bd5fa5 LC |
1220 | (define (fold/tree proc seed lst) |
1221 | "Like 'fold', but recurse into sub-lists of LST and accept improper lists." | |
1222 | (let loop ((obj lst) | |
1223 | (result seed)) | |
1224 | (match obj | |
1225 | ((head . tail) | |
1226 | (loop tail (loop head result))) | |
1227 | (_ | |
1228 | (proc obj result))))) | |
1229 | ||
4fa9d48f LC |
1230 | (define (gexp-inputs exp) |
1231 | "Return the list of <gexp-input> for EXP." | |
1232 | (define set-gexp-input-native? | |
1233 | (match-lambda | |
1234 | (($ <gexp-input> thing output) | |
1235 | (%gexp-input thing output #t)))) | |
1236 | ||
c8bd5fa5 LC |
1237 | (define (interesting? obj) |
1238 | (or (file-like? obj) | |
1239 | (and (string? obj) (direct-store-path? obj)))) | |
1240 | ||
21b679f6 LC |
1241 | (define (add-reference-inputs ref result) |
1242 | (match ref | |
1123759b | 1243 | (($ <gexp-input> (? gexp? exp) _ #t) |
4fa9d48f | 1244 | (append (map set-gexp-input-native? (gexp-inputs exp)) |
d343a60f | 1245 | result)) |
4fa9d48f LC |
1246 | (($ <gexp-input> (? gexp? exp) _ #f) |
1247 | (append (gexp-inputs exp) result)) | |
e39d1461 LC |
1248 | (($ <gexp-input> (? string? str)) |
1249 | (if (direct-store-path? str) | |
fc6d6aee | 1250 | (cons ref result) |
21b679f6 | 1251 | result)) |
5b14a790 | 1252 | (($ <gexp-input> (? struct? thing) output n?) |
4fa9d48f | 1253 | (if (lookup-compiler thing) |
bcb13287 | 1254 | ;; THING is a derivation, or a package, or an origin, etc. |
fc6d6aee | 1255 | (cons ref result) |
bcb13287 | 1256 | result)) |
c8bd5fa5 LC |
1257 | (($ <gexp-input> (? pair? lst) output n?) |
1258 | ;; XXX: Scan LST for inputs. Inherit N?. | |
1259 | (fold/tree (lambda (obj result) | |
1260 | (match obj | |
1261 | ((? gexp-input? x) | |
1262 | (cons (%gexp-input (gexp-input-thing x) | |
1263 | (gexp-input-output x) | |
1264 | n?) | |
1265 | result)) | |
1266 | ((? interesting? x) | |
1267 | (cons (%gexp-input x "out" n?) result)) | |
1268 | ((? gexp? x) | |
1269 | (append (gexp-inputs x) result)) | |
1270 | (_ | |
1271 | result))) | |
1272 | result | |
1273 | lst)) | |
21b679f6 LC |
1274 | (_ |
1275 | ;; Ignore references to other kinds of objects. | |
1276 | result))) | |
1277 | ||
1278 | (fold-right add-reference-inputs | |
1279 | '() | |
5b14a790 | 1280 | (gexp-references exp))) |
667b2508 | 1281 | |
21b679f6 LC |
1282 | (define (gexp-outputs exp) |
1283 | "Return the outputs referred to by EXP as a list of strings." | |
1284 | (define (add-reference-output ref result) | |
1285 | (match ref | |
1e87da58 | 1286 | (($ <gexp-output> name) |
21b679f6 | 1287 | (cons name result)) |
e39d1461 | 1288 | (($ <gexp-input> (? gexp? exp)) |
21b679f6 | 1289 | (append (gexp-outputs exp) result)) |
c8bd5fa5 LC |
1290 | (($ <gexp-input> (? pair? lst)) |
1291 | ;; XXX: Scan LST for outputs. | |
1292 | (fold/tree (lambda (obj result) | |
1293 | (match obj | |
1294 | (($ <gexp-output> name) (cons name result)) | |
1295 | ((? gexp? x) (append (gexp-outputs x) result)) | |
1296 | (_ result))) | |
1297 | result | |
1298 | lst)) | |
21b679f6 LC |
1299 | (_ |
1300 | result))) | |
1301 | ||
7e75a673 | 1302 | (delete-duplicates |
c8bd5fa5 | 1303 | (fold add-reference-output '() (gexp-references exp)))) |
21b679f6 | 1304 | |
b57de6fe | 1305 | (define (gexp->sexp exp system target) |
21b679f6 LC |
1306 | "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, |
1307 | and in the current monad setting (system type, etc.)" | |
667b2508 | 1308 | (define* (reference->sexp ref #:optional native?) |
21b679f6 LC |
1309 | (with-monad %store-monad |
1310 | (match ref | |
1e87da58 | 1311 | (($ <gexp-output> output) |
bfd9eed9 LC |
1312 | ;; Output file names are not known in advance but the daemon defines |
1313 | ;; an environment variable for each of them at build time, so use | |
1314 | ;; that trick. | |
1315 | (return `((@ (guile) getenv) ,output))) | |
e39d1461 | 1316 | (($ <gexp-input> (? gexp? exp) output n?) |
667b2508 | 1317 | (gexp->sexp exp |
b57de6fe | 1318 | system (if (or n? native?) #f target))) |
e39d1461 | 1319 | (($ <gexp-input> (refs ...) output n?) |
b334674f LC |
1320 | (mapm %store-monad |
1321 | (lambda (ref) | |
1322 | ;; XXX: Automatically convert REF to an gexp-input. | |
c8bd5fa5 LC |
1323 | (if (or (symbol? ref) (number? ref) |
1324 | (boolean? ref) (null? ref) (array? ref)) | |
1325 | (return ref) | |
1326 | (reference->sexp | |
1327 | (if (gexp-input? ref) | |
1328 | ref | |
1329 | (%gexp-input ref "out" n?)) | |
1330 | (or n? native?)))) | |
b334674f | 1331 | refs)) |
bcb13287 | 1332 | (($ <gexp-input> (? struct? thing) output n?) |
d03001a3 LC |
1333 | (let ((target (if (or n? native?) #f target))) |
1334 | (lower+expand-object thing system | |
1335 | #:target target | |
1336 | #:output output))) | |
24ab804c | 1337 | (($ <gexp-input> (? self-quoting? x)) |
e39d1461 | 1338 | (return x)) |
24ab804c LC |
1339 | (($ <gexp-input> x) |
1340 | (raise (condition (&gexp-input-error (input x))))) | |
21b679f6 LC |
1341 | (x |
1342 | (return x))))) | |
1343 | ||
1344 | (mlet %store-monad | |
b334674f LC |
1345 | ((args (mapm %store-monad |
1346 | reference->sexp (gexp-references exp)))) | |
21b679f6 LC |
1347 | (return (apply (gexp-proc exp) args)))) |
1348 | ||
4f621a2b | 1349 | (define-syntax-parameter current-imported-modules |
0bb9929e LC |
1350 | ;; Current list of imported modules. |
1351 | (identifier-syntax '())) | |
1352 | ||
1353 | (define-syntax-rule (with-imported-modules modules body ...) | |
1354 | "Mark the gexps defined in BODY... as requiring MODULES in their execution | |
1355 | environment." | |
1356 | (syntax-parameterize ((current-imported-modules | |
1357 | (identifier-syntax modules))) | |
1358 | body ...)) | |
1359 | ||
4f621a2b | 1360 | (define-syntax-parameter current-imported-extensions |
838e17d8 LC |
1361 | ;; Current list of extensions. |
1362 | (identifier-syntax '())) | |
1363 | ||
1364 | (define-syntax-rule (with-extensions extensions body ...) | |
1365 | "Mark the gexps defined in BODY... as requiring EXTENSIONS in their | |
1366 | execution environment." | |
1367 | (syntax-parameterize ((current-imported-extensions | |
1368 | (identifier-syntax extensions))) | |
1369 | body ...)) | |
1370 | ||
21b679f6 LC |
1371 | (define-syntax gexp |
1372 | (lambda (s) | |
1373 | (define (collect-escapes exp) | |
1374 | ;; Return all the 'ungexp' present in EXP. | |
1375 | (let loop ((exp exp) | |
1376 | (result '())) | |
607e1b51 LC |
1377 | (syntax-case exp (ungexp |
1378 | ungexp-splicing | |
1379 | ungexp-native | |
1380 | ungexp-native-splicing) | |
21b679f6 LC |
1381 | ((ungexp _) |
1382 | (cons exp result)) | |
1383 | ((ungexp _ _) | |
1384 | (cons exp result)) | |
1385 | ((ungexp-splicing _ ...) | |
1386 | (cons exp result)) | |
607e1b51 | 1387 | ((ungexp-native _ ...) |
667b2508 LC |
1388 | (cons exp result)) |
1389 | ((ungexp-native-splicing _ ...) | |
1390 | (cons exp result)) | |
5e2e4a51 | 1391 | ((exp0 . exp) |
667b2508 | 1392 | (let ((result (loop #'exp0 result))) |
5e2e4a51 | 1393 | (loop #'exp result))) |
667b2508 LC |
1394 | (_ |
1395 | result)))) | |
1396 | ||
21b679f6 LC |
1397 | (define (escape->ref exp) |
1398 | ;; Turn 'ungexp' form EXP into a "reference". | |
667b2508 LC |
1399 | (syntax-case exp (ungexp ungexp-splicing |
1400 | ungexp-native ungexp-native-splicing | |
1401 | output) | |
21b679f6 | 1402 | ((ungexp output) |
1e87da58 | 1403 | #'(gexp-output "out")) |
21b679f6 | 1404 | ((ungexp output name) |
1e87da58 | 1405 | #'(gexp-output name)) |
21b679f6 | 1406 | ((ungexp thing) |
0dbea56b | 1407 | #'(%gexp-input thing "out" #f)) |
21b679f6 | 1408 | ((ungexp drv-or-pkg out) |
0dbea56b | 1409 | #'(%gexp-input drv-or-pkg out #f)) |
21b679f6 | 1410 | ((ungexp-splicing lst) |
0dbea56b | 1411 | #'(%gexp-input lst "out" #f)) |
667b2508 | 1412 | ((ungexp-native thing) |
0dbea56b | 1413 | #'(%gexp-input thing "out" #t)) |
667b2508 | 1414 | ((ungexp-native drv-or-pkg out) |
0dbea56b | 1415 | #'(%gexp-input drv-or-pkg out #t)) |
667b2508 | 1416 | ((ungexp-native-splicing lst) |
0dbea56b | 1417 | #'(%gexp-input lst "out" #t)))) |
21b679f6 | 1418 | |
667b2508 LC |
1419 | (define (substitute-ungexp exp substs) |
1420 | ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with | |
1421 | ;; the corresponding form in SUBSTS. | |
1422 | (match (assoc exp substs) | |
1423 | ((_ id) | |
1424 | id) | |
4a6e889f LC |
1425 | (_ ;internal error |
1426 | (with-syntax ((exp exp)) | |
1427 | #'(syntax-error "error: no 'ungexp' substitution" exp))))) | |
667b2508 LC |
1428 | |
1429 | (define (substitute-ungexp-splicing exp substs) | |
1430 | (syntax-case exp () | |
1431 | ((exp rest ...) | |
1432 | (match (assoc #'exp substs) | |
1433 | ((_ id) | |
1434 | (with-syntax ((id id)) | |
1435 | #`(append id | |
1436 | #,(substitute-references #'(rest ...) substs)))) | |
1437 | (_ | |
1438 | #'(syntax-error "error: no 'ungexp-splicing' substitution" | |
4a6e889f | 1439 | exp)))))) |
667b2508 | 1440 | |
21b679f6 LC |
1441 | (define (substitute-references exp substs) |
1442 | ;; Return a variant of EXP where all the cars of SUBSTS have been | |
1443 | ;; replaced by the corresponding cdr. | |
667b2508 LC |
1444 | (syntax-case exp (ungexp ungexp-native |
1445 | ungexp-splicing ungexp-native-splicing) | |
21b679f6 | 1446 | ((ungexp _ ...) |
667b2508 LC |
1447 | (substitute-ungexp exp substs)) |
1448 | ((ungexp-native _ ...) | |
1449 | (substitute-ungexp exp substs)) | |
21b679f6 | 1450 | (((ungexp-splicing _ ...) rest ...) |
667b2508 LC |
1451 | (substitute-ungexp-splicing exp substs)) |
1452 | (((ungexp-native-splicing _ ...) rest ...) | |
1453 | (substitute-ungexp-splicing exp substs)) | |
5e2e4a51 | 1454 | ((exp0 . exp) |
21b679f6 | 1455 | #`(cons #,(substitute-references #'exp0 substs) |
5e2e4a51 | 1456 | #,(substitute-references #'exp substs))) |
21b679f6 LC |
1457 | (x #''x))) |
1458 | ||
1459 | (syntax-case s (ungexp output) | |
1460 | ((_ exp) | |
affd7761 | 1461 | (let* ((escapes (delete-duplicates (collect-escapes #'exp))) |
21b679f6 LC |
1462 | (formals (generate-temporaries escapes)) |
1463 | (sexp (substitute-references #'exp (zip escapes formals))) | |
affd7761 LC |
1464 | (refs (map escape->ref escapes))) |
1465 | #`(make-gexp (list #,@refs) | |
0bb9929e | 1466 | current-imported-modules |
838e17d8 | 1467 | current-imported-extensions |
21b679f6 | 1468 | (lambda #,formals |
18fc84bc LC |
1469 | #,sexp) |
1470 | (current-source-location))))))) | |
21b679f6 LC |
1471 | |
1472 | \f | |
aa72d9af LC |
1473 | ;;; |
1474 | ;;; Module handling. | |
1475 | ;;; | |
1476 | ||
df2d51f0 LC |
1477 | (define %utils-module |
1478 | ;; This file provides 'mkdir-p', needed to implement 'imported-files' and | |
a9601e23 LC |
1479 | ;; other primitives below. Note: We give the file name relative to this |
1480 | ;; file you are currently reading; 'search-path' could return a file name | |
1481 | ;; relative to the current working directory. | |
1482 | (local-file "build/utils.scm" | |
df2d51f0 | 1483 | "build-utils.scm")) |
aa72d9af | 1484 | |
8df2eca6 LC |
1485 | (define* (imported-files/derivation files |
1486 | #:key (name "file-import") | |
e529d468 | 1487 | (symlink? #f) |
8df2eca6 | 1488 | (system (%current-system)) |
8afa18d6 | 1489 | (guile (%guile-for-build))) |
aa72d9af | 1490 | "Return a derivation that imports FILES into STORE. FILES must be a list |
d938a58b LC |
1491 | of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the |
1492 | resulting store path. FILE can be either a file name, or a file-like object, | |
e529d468 LC |
1493 | as returned by 'local-file' for example. If SYMLINK? is true, create symlinks |
1494 | to the source files instead of copying them." | |
aa72d9af LC |
1495 | (define file-pair |
1496 | (match-lambda | |
d938a58b | 1497 | ((final-path . (? string? file-name)) |
aa72d9af LC |
1498 | (mlet %store-monad ((file (interned-file file-name |
1499 | (basename final-path)))) | |
d938a58b LC |
1500 | (return (list final-path file)))) |
1501 | ((final-path . file-like) | |
1502 | (mlet %store-monad ((file (lower-object file-like system))) | |
aa72d9af LC |
1503 | (return (list final-path file)))))) |
1504 | ||
b334674f | 1505 | (mlet %store-monad ((files (mapm %store-monad file-pair files))) |
aa72d9af LC |
1506 | (define build |
1507 | (gexp | |
1508 | (begin | |
df2d51f0 | 1509 | (primitive-load (ungexp %utils-module)) ;for 'mkdir-p' |
aa72d9af LC |
1510 | (use-modules (ice-9 match)) |
1511 | ||
aa72d9af LC |
1512 | (mkdir (ungexp output)) (chdir (ungexp output)) |
1513 | (for-each (match-lambda | |
1514 | ((final-path store-path) | |
1515 | (mkdir-p (dirname final-path)) | |
e529d468 LC |
1516 | ((ungexp (if symlink? 'symlink 'copy-file)) |
1517 | store-path final-path))) | |
aa72d9af LC |
1518 | '(ungexp files))))) |
1519 | ||
1520 | ;; TODO: Pass FILES as an environment variable so that BUILD remains | |
1521 | ;; exactly the same regardless of FILES: less disk space, and fewer | |
1522 | ;; 'add-to-store' RPCs. | |
1523 | (gexp->derivation name build | |
1524 | #:system system | |
1525 | #:guile-for-build guile | |
30d722c3 | 1526 | #:local-build? #t |
2c402b1a | 1527 | #:substitutable? #f |
30d722c3 | 1528 | |
8afa18d6 LC |
1529 | ;; Avoid deprecation warnings about the use of the _IO* |
1530 | ;; constants in (guix build utils). | |
30d722c3 | 1531 | #:env-vars |
8afa18d6 | 1532 | '(("GUILE_WARN_DEPRECATED" . "no"))))) |
aa72d9af | 1533 | |
8df2eca6 LC |
1534 | (define* (imported-files files |
1535 | #:key (name "file-import") | |
8df2eca6 LC |
1536 | ;; The following parameters make sense when creating |
1537 | ;; an actual derivation. | |
1538 | (system (%current-system)) | |
8afa18d6 | 1539 | (guile (%guile-for-build))) |
8df2eca6 LC |
1540 | "Import FILES into the store and return the resulting derivation or store |
1541 | file name (a derivation is created if and only if some elements of FILES are | |
1542 | file-like objects and not local file names.) FILES must be a list | |
1543 | of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the | |
1544 | resulting store path. FILE can be either a file name, or a file-like object, | |
1545 | as returned by 'local-file' for example." | |
8c7bebd6 LC |
1546 | (if (any (match-lambda |
1547 | ((_ . (? struct? source)) #t) | |
1548 | (_ #f)) | |
1549 | files) | |
8df2eca6 | 1550 | (imported-files/derivation files #:name name |
e529d468 | 1551 | #:symlink? derivation? |
8afa18d6 | 1552 | #:system system #:guile guile) |
8df2eca6 LC |
1553 | (interned-file-tree `(,name directory |
1554 | ,@(file-mapping->tree files))))) | |
1555 | ||
aa72d9af LC |
1556 | (define* (imported-modules modules |
1557 | #:key (name "module-import") | |
1558 | (system (%current-system)) | |
1559 | (guile (%guile-for-build)) | |
8afa18d6 | 1560 | (module-path %load-path)) |
aa72d9af | 1561 | "Return a derivation that contains the source files of MODULES, a list of |
d938a58b LC |
1562 | module names such as `(ice-9 q)'. All of MODULES must be either names of |
1563 | modules to be found in the MODULE-PATH search path, or a module name followed | |
1564 | by an arrow followed by a file-like object. For example: | |
1565 | ||
1566 | (imported-modules `((guix build utils) | |
1567 | (guix gcrypt) | |
1568 | ((guix config) => ,(scheme-file …)))) | |
1569 | ||
1570 | In this example, the first two modules are taken from MODULE-PATH, and the | |
1571 | last one is created from the given <scheme-file> object." | |
4d20d87b LC |
1572 | (let ((files (map (match-lambda |
1573 | (((module ...) '=> file) | |
1574 | (cons (module->source-file-name module) | |
1575 | file)) | |
1576 | ((module ...) | |
1577 | (let ((f (module->source-file-name module))) | |
1578 | (cons f (search-path* module-path f))))) | |
1579 | modules))) | |
8df2eca6 | 1580 | (imported-files files #:name name |
8df2eca6 | 1581 | #:system system |
8afa18d6 | 1582 | #:guile guile))) |
aa72d9af LC |
1583 | |
1584 | (define* (compiled-modules modules | |
1585 | #:key (name "module-import-compiled") | |
1586 | (system (%current-system)) | |
2cc5ec7f | 1587 | target |
aa72d9af | 1588 | (guile (%guile-for-build)) |
a912c723 | 1589 | (module-path %load-path) |
838e17d8 | 1590 | (extensions '()) |
3c6b9fb5 | 1591 | (deprecation-warnings #f)) |
aa72d9af LC |
1592 | "Return a derivation that builds a tree containing the `.go' files |
1593 | corresponding to MODULES. All the MODULES are built in a context where | |
2cc5ec7f LC |
1594 | they can refer to each other. When TARGET is true, cross-compile MODULES for |
1595 | TARGET, a GNU triplet." | |
d3292275 LC |
1596 | (define total (length modules)) |
1597 | ||
aa72d9af LC |
1598 | (mlet %store-monad ((modules (imported-modules modules |
1599 | #:system system | |
1600 | #:guile guile | |
1601 | #:module-path | |
8afa18d6 | 1602 | module-path))) |
aa72d9af LC |
1603 | (define build |
1604 | (gexp | |
1605 | (begin | |
df2d51f0 LC |
1606 | (primitive-load (ungexp %utils-module)) ;for 'mkdir-p' |
1607 | ||
aa72d9af | 1608 | (use-modules (ice-9 ftw) |
d3292275 LC |
1609 | (ice-9 format) |
1610 | (srfi srfi-1) | |
aa72d9af | 1611 | (srfi srfi-26) |
326dc630 | 1612 | (system base target) |
aa72d9af LC |
1613 | (system base compile)) |
1614 | ||
aa72d9af LC |
1615 | (define (regular? file) |
1616 | (not (member file '("." "..")))) | |
1617 | ||
d3292275 | 1618 | (define (process-entry entry output processed) |
e640c9e6 LC |
1619 | (if (file-is-directory? entry) |
1620 | (let ((output (string-append output "/" (basename entry)))) | |
1621 | (mkdir-p output) | |
d3292275 | 1622 | (process-directory entry output processed)) |
e640c9e6 LC |
1623 | (let* ((base (basename entry ".scm")) |
1624 | (output (string-append output "/" base ".go"))) | |
d3292275 | 1625 | (format #t "[~2@a/~2@a] Compiling '~a'...~%" |
3c6b9fb5 LC |
1626 | (+ 1 processed (ungexp total)) |
1627 | (ungexp (* total 2)) | |
a31174e8 | 1628 | entry) |
2cc5ec7f LC |
1629 | |
1630 | (ungexp-splicing | |
1631 | (if target | |
1632 | (gexp ((with-target (ungexp target) | |
1633 | (lambda () | |
1634 | (compile-file entry | |
1635 | #:output-file output | |
1636 | #:opts | |
1637 | %auto-compilation-options))))) | |
1638 | (gexp ((compile-file entry | |
1639 | #:output-file output | |
1640 | #:opts %auto-compilation-options))))) | |
1641 | ||
d3292275 | 1642 | (+ 1 processed)))) |
e640c9e6 | 1643 | |
d3292275 | 1644 | (define (process-directory directory output processed) |
aa72d9af LC |
1645 | (let ((entries (map (cut string-append directory "/" <>) |
1646 | (scandir directory regular?)))) | |
d3292275 LC |
1647 | (fold (cut process-entry <> output <>) |
1648 | processed | |
1649 | entries))) | |
1650 | ||
3c6b9fb5 LC |
1651 | (define* (load-from-directory directory |
1652 | #:optional (loaded 0)) | |
1653 | "Load all the source files found in DIRECTORY." | |
1654 | ;; XXX: This works around <https://bugs.gnu.org/15602>. | |
1655 | (let ((entries (map (cut string-append directory "/" <>) | |
1656 | (scandir directory regular?)))) | |
1657 | (fold (lambda (file loaded) | |
1658 | (if (file-is-directory? file) | |
1659 | (load-from-directory file loaded) | |
1660 | (begin | |
1661 | (format #t "[~2@a/~2@a] Loading '~a'...~%" | |
1662 | (+ 1 loaded) (ungexp (* 2 total)) | |
1663 | file) | |
1664 | (save-module-excursion | |
1665 | (lambda () | |
1666 | (primitive-load file))) | |
1667 | (+ 1 loaded)))) | |
1668 | loaded | |
1669 | entries))) | |
1670 | ||
d3292275 LC |
1671 | (setvbuf (current-output-port) |
1672 | (cond-expand (guile-2.2 'line) (else _IOLBF))) | |
aa72d9af | 1673 | |
4a42abc5 LC |
1674 | (define mkdir-p |
1675 | ;; Capture 'mkdir-p'. | |
1676 | (@ (guix build utils) mkdir-p)) | |
5d669883 | 1677 | |
838e17d8 | 1678 | ;; Add EXTENSIONS to the search path. |
4a42abc5 LC |
1679 | (set! %load-path |
1680 | (append (map (lambda (extension) | |
1681 | (string-append extension | |
1682 | "/share/guile/site/" | |
1683 | (effective-version))) | |
1684 | '((ungexp-native-splicing extensions))) | |
1685 | %load-path)) | |
1686 | (set! %load-compiled-path | |
1687 | (append (map (lambda (extension) | |
1688 | (string-append extension "/lib/guile/" | |
1689 | (effective-version) | |
1690 | "/site-ccache")) | |
1691 | '((ungexp-native-splicing extensions))) | |
1692 | %load-compiled-path)) | |
838e17d8 | 1693 | |
aa72d9af | 1694 | (set! %load-path (cons (ungexp modules) %load-path)) |
5d669883 | 1695 | |
4a42abc5 LC |
1696 | ;; Above we loaded our own (guix build utils) but now we may need to |
1697 | ;; load a compile a different one. Thus, force a reload. | |
1698 | (let ((utils (string-append (ungexp modules) | |
1699 | "/guix/build/utils.scm"))) | |
1700 | (when (file-exists? utils) | |
1701 | (load utils))) | |
5d669883 | 1702 | |
aa72d9af LC |
1703 | (mkdir (ungexp output)) |
1704 | (chdir (ungexp modules)) | |
a31174e8 | 1705 | |
3c6b9fb5 | 1706 | (load-from-directory ".") |
d3292275 | 1707 | (process-directory "." (ungexp output) 0)))) |
aa72d9af LC |
1708 | |
1709 | ;; TODO: Pass MODULES as an environment variable. | |
1710 | (gexp->derivation name build | |
1711 | #:system system | |
6de3ef0d | 1712 | #:target target |
aa72d9af | 1713 | #:guile-for-build guile |
a912c723 LC |
1714 | #:local-build? #t |
1715 | #:env-vars | |
1716 | (case deprecation-warnings | |
1717 | ((#f) | |
1718 | '(("GUILE_WARN_DEPRECATED" . "no"))) | |
1719 | ((detailed) | |
1720 | '(("GUILE_WARN_DEPRECATED" . "detailed"))) | |
1721 | (else | |
1722 | '()))))) | |
aa72d9af LC |
1723 | |
1724 | \f | |
21b679f6 LC |
1725 | ;;; |
1726 | ;;; Convenience procedures. | |
1727 | ;;; | |
1728 | ||
53e89b17 | 1729 | (define (default-guile) |
b6bee63b | 1730 | ;; Lazily resolve 'guile-3.0' (not 'guile-final' because this is for |
6ee797f3 LC |
1731 | ;; programs returned by 'program-file' and we don't want to keep references |
1732 | ;; to several Guile packages). This module must not refer to (gnu …) | |
53e89b17 | 1733 | ;; modules directly, to avoid circular dependencies, hence this hack. |
6ee797f3 | 1734 | (module-ref (resolve-interface '(gnu packages guile)) |
b6bee63b | 1735 | 'guile-3.0)) |
53e89b17 | 1736 | |
838e17d8 | 1737 | (define* (load-path-expression modules #:optional (path %load-path) |
58210fbe LC |
1738 | #:key (extensions '()) system target |
1739 | (guile (default-guile))) | |
dd8d1a30 | 1740 | "Return as a monadic value a gexp that sets '%load-path' and |
1ae16033 | 1741 | '%load-compiled-path' to point to MODULES, a list of module names. MODULES |
58210fbe LC |
1742 | are searched for in PATH. Return #f when MODULES and EXTENSIONS are empty. |
1743 | Assume MODULES are compiled with GUILE." | |
efff3245 LC |
1744 | (if (and (null? modules) (null? extensions)) |
1745 | (with-monad %store-monad | |
1746 | (return #f)) | |
58210fbe LC |
1747 | (mlet* %store-monad ((guile (lower-object guile system #:target #f)) |
1748 | (compiled (compiled-modules modules | |
1749 | #:guile guile | |
1750 | #:extensions extensions | |
1751 | #:module-path path | |
1752 | #:system system | |
1753 | #:target target)) | |
1754 | (modules (imported-modules modules | |
1755 | #:guile guile | |
1756 | #:module-path path | |
1757 | #:system system))) | |
cdf9811d LC |
1758 | (return |
1759 | (gexp (eval-when (expand load eval) | |
1760 | ;; Augment the load paths and delete duplicates. Do that | |
1761 | ;; without loading (srfi srfi-1) or anything. | |
396b05f0 | 1762 | (let ((extensions '((ungexp-splicing extensions))) |
cdf9811d LC |
1763 | (prepend (lambda (items lst) |
1764 | ;; This is O(N²) but N is typically small. | |
1765 | (let loop ((items items) | |
1766 | (lst lst)) | |
1767 | (if (null? items) | |
1768 | lst | |
1769 | (loop (cdr items) | |
1770 | (cons (car items) | |
1771 | (delete (car items) lst)))))))) | |
1772 | (set! %load-path | |
1773 | (prepend (cons (ungexp modules) | |
1774 | (map (lambda (extension) | |
1775 | (string-append extension | |
1776 | "/share/guile/site/" | |
1777 | (effective-version))) | |
1778 | extensions)) | |
1779 | %load-path)) | |
1780 | (set! %load-compiled-path | |
1781 | (prepend (cons (ungexp compiled) | |
1782 | (map (lambda (extension) | |
1783 | (string-append extension | |
1784 | "/lib/guile/" | |
1785 | (effective-version) | |
1786 | "/site-ccache")) | |
1787 | extensions)) | |
1788 | %load-compiled-path))))))))) | |
dd8d1a30 | 1789 | |
21b679f6 | 1790 | (define* (gexp->script name exp |
1ae16033 | 1791 | #:key (guile (default-guile)) |
2e8cabb8 LC |
1792 | (module-path %load-path) |
1793 | (system (%current-system)) | |
a6bf7a97 | 1794 | (target 'current)) |
9c14a487 | 1795 | "Return an executable script NAME that runs EXP using GUILE, with EXP's |
1ae16033 | 1796 | imported modules in its search path. Look up EXP's modules in MODULE-PATH." |
a6bf7a97 MO |
1797 | (mlet* %store-monad ((target (if (eq? target 'current) |
1798 | (current-target-system) | |
1799 | (return target))) | |
1800 | (set-load-path | |
1801 | (load-path-expression (gexp-modules exp) | |
1802 | module-path | |
19c6ea9c | 1803 | #:guile guile |
a6bf7a97 MO |
1804 | #:extensions |
1805 | (gexp-extensions exp) | |
1806 | #:system system | |
19c6ea9c LC |
1807 | #:target target)) |
1808 | (guile-for-build | |
1809 | (lower-object guile system #:target #f))) | |
21b679f6 LC |
1810 | (gexp->derivation name |
1811 | (gexp | |
1812 | (call-with-output-file (ungexp output) | |
1813 | (lambda (port) | |
c17b5ab4 LC |
1814 | ;; Note: that makes a long shebang. When the store |
1815 | ;; is /gnu/store, that fits within the 128-byte | |
1816 | ;; limit imposed by Linux, but that may go beyond | |
1817 | ;; when running tests. | |
21b679f6 LC |
1818 | (format port |
1819 | "#!~a/bin/guile --no-auto-compile~%!#~%" | |
1820 | (ungexp guile)) | |
4a4cbd0b | 1821 | |
efff3245 LC |
1822 | (ungexp-splicing |
1823 | (if set-load-path | |
1824 | (gexp ((write '(ungexp set-load-path) port))) | |
1825 | (gexp ()))) | |
1826 | ||
21b679f6 | 1827 | (write '(ungexp exp) port) |
1ae16033 | 1828 | (chmod port #o555)))) |
2e8cabb8 LC |
1829 | #:system system |
1830 | #:target target | |
52207b39 | 1831 | #:module-path module-path |
19c6ea9c | 1832 | #:guile-for-build guile-for-build |
52207b39 LC |
1833 | |
1834 | ;; These derivations are not worth offloading or | |
1835 | ;; substituting. | |
1836 | #:local-build? #t | |
1837 | #:substitutable? #f))) | |
21b679f6 | 1838 | |
1ae16033 LC |
1839 | (define* (gexp->file name exp #:key |
1840 | (set-load-path? #t) | |
4fbd1a2b | 1841 | (module-path %load-path) |
3cd1444d MO |
1842 | (splice? #f) |
1843 | (system (%current-system)) | |
a6bf7a97 | 1844 | (target 'current)) |
4fbd1a2b LC |
1845 | "Return a derivation that builds a file NAME containing EXP. When SPLICE? |
1846 | is true, EXP is considered to be a list of expressions that will be spliced in | |
1847 | the resulting file. | |
1848 | ||
1849 | When SET-LOAD-PATH? is true, emit code in the resulting file to set | |
1850 | '%load-path' and '%load-compiled-path' to honor EXP's imported modules. | |
1851 | Lookup EXP's modules in MODULE-PATH." | |
838e17d8 LC |
1852 | (define modules (gexp-modules exp)) |
1853 | (define extensions (gexp-extensions exp)) | |
1854 | ||
a6bf7a97 MO |
1855 | (mlet* %store-monad |
1856 | ((target (if (eq? target 'current) | |
1857 | (current-target-system) | |
1858 | (return target))) | |
1859 | (no-load-path? -> (or (not set-load-path?) | |
1860 | (and (null? modules) | |
1861 | (null? extensions)))) | |
1862 | (set-load-path | |
1863 | (load-path-expression modules module-path | |
1864 | #:extensions extensions | |
1865 | #:system system | |
1866 | #:target target))) | |
1867 | (if no-load-path? | |
1868 | (gexp->derivation name | |
1869 | (gexp | |
1870 | (call-with-output-file (ungexp output) | |
1871 | (lambda (port) | |
1872 | (for-each | |
1873 | (lambda (exp) | |
1874 | (write exp port)) | |
1875 | '(ungexp (if splice? | |
1876 | exp | |
1877 | (gexp ((ungexp exp))))))))) | |
1878 | #:local-build? #t | |
1879 | #:substitutable? #f | |
1880 | #:system system | |
1881 | #:target target) | |
838e17d8 LC |
1882 | (gexp->derivation name |
1883 | (gexp | |
1884 | (call-with-output-file (ungexp output) | |
1885 | (lambda (port) | |
1886 | (write '(ungexp set-load-path) port) | |
a6bf7a97 MO |
1887 | (for-each |
1888 | (lambda (exp) | |
1889 | (write exp port)) | |
1890 | '(ungexp (if splice? | |
1891 | exp | |
1892 | (gexp ((ungexp exp))))))))) | |
838e17d8 LC |
1893 | #:module-path module-path |
1894 | #:local-build? #t | |
3cd1444d MO |
1895 | #:substitutable? #f |
1896 | #:system system | |
1897 | #:target target)))) | |
21b679f6 | 1898 | |
462a3fa3 LC |
1899 | (define* (text-file* name #:rest text) |
1900 | "Return as a monadic value a derivation that builds a text file containing | |
d9ae938f LC |
1901 | all of TEXT. TEXT may list, in addition to strings, objects of any type that |
1902 | can be used in a gexp: packages, derivations, local file objects, etc. The | |
1903 | resulting store file holds references to all these." | |
462a3fa3 LC |
1904 | (define builder |
1905 | (gexp (call-with-output-file (ungexp output "out") | |
1906 | (lambda (port) | |
1907 | (display (string-append (ungexp-splicing text)) port))))) | |
1908 | ||
851b6f62 LC |
1909 | (gexp->derivation name builder |
1910 | #:local-build? #t | |
1911 | #:substitutable? #f)) | |
462a3fa3 | 1912 | |
b751cde3 LC |
1913 | (define* (mixed-text-file name #:rest text) |
1914 | "Return an object representing store file NAME containing TEXT. TEXT is a | |
1915 | sequence of strings and file-like objects, as in: | |
1916 | ||
1917 | (mixed-text-file \"profile\" | |
1918 | \"export PATH=\" coreutils \"/bin:\" grep \"/bin\") | |
1919 | ||
1920 | This is the declarative counterpart of 'text-file*'." | |
1921 | (define build | |
1922 | (gexp (call-with-output-file (ungexp output "out") | |
1923 | (lambda (port) | |
1924 | (display (string-append (ungexp-splicing text)) port))))) | |
1925 | ||
1926 | (computed-file name build)) | |
1927 | ||
dedb512f LC |
1928 | (define (file-union name files) |
1929 | "Return a <computed-file> that builds a directory containing all of FILES. | |
1930 | Each item in FILES must be a two-element list where the first element is the | |
1931 | file name to use in the new directory, and the second element is a gexp | |
1932 | denoting the target file. Here's an example: | |
1933 | ||
1934 | (file-union \"etc\" | |
1935 | `((\"hosts\" ,(plain-file \"hosts\" | |
1936 | \"127.0.0.1 localhost\")) | |
1937 | (\"bashrc\" ,(plain-file \"bashrc\" | |
5dec93bb LC |
1938 | \"alias ls='ls --color'\")) |
1939 | (\"libvirt/qemu.conf\" ,(plain-file \"qemu.conf\" \"\")))) | |
dedb512f LC |
1940 | |
1941 | This yields an 'etc' directory containing these two files." | |
1942 | (computed-file name | |
5dec93bb LC |
1943 | (with-imported-modules '((guix build utils)) |
1944 | (gexp | |
1945 | (begin | |
1946 | (use-modules (guix build utils)) | |
1947 | ||
1948 | (mkdir (ungexp output)) | |
1949 | (chdir (ungexp output)) | |
1950 | (ungexp-splicing | |
1951 | (map (match-lambda | |
1952 | ((target source) | |
1953 | (gexp | |
1954 | (begin | |
1955 | ;; Stat the source to abort early if it does | |
1956 | ;; not exist. | |
1957 | (stat (ungexp source)) | |
1958 | ||
1959 | (mkdir-p (dirname (ungexp target))) | |
1960 | (symlink (ungexp source) | |
1961 | (ungexp target)))))) | |
1962 | files))))))) | |
dedb512f | 1963 | |
59523429 | 1964 | (define* (directory-union name things |
b244ae25 LC |
1965 | #:key (copy? #f) (quiet? #f) |
1966 | (resolve-collision 'warn-about-collision)) | |
d298c815 LC |
1967 | "Return a directory that is the union of THINGS, where THINGS is a list of |
1968 | file-like objects denoting directories. For example: | |
1969 | ||
1970 | (directory-union \"guile+emacs\" (list guile emacs)) | |
1971 | ||
59523429 LC |
1972 | yields a directory that is the union of the 'guile' and 'emacs' packages. |
1973 | ||
b244ae25 LC |
1974 | Call RESOLVE-COLLISION when several files collide, passing it the list of |
1975 | colliding files. RESOLVE-COLLISION must return the chosen file or #f, in | |
1976 | which case the colliding entry is skipped altogether. | |
1977 | ||
de98b302 LC |
1978 | When HARD-LINKS? is true, create hard links instead of symlinks. When QUIET? |
1979 | is true, the derivation will not print anything." | |
59523429 LC |
1980 | (define symlink |
1981 | (if copy? | |
1982 | (gexp (lambda (old new) | |
1983 | (if (file-is-directory? old) | |
1984 | (symlink old new) | |
1985 | (copy-file old new)))) | |
1986 | (gexp symlink))) | |
1987 | ||
de98b302 LC |
1988 | (define log-port |
1989 | (if quiet? | |
1990 | (gexp (%make-void-port "w")) | |
1991 | (gexp (current-error-port)))) | |
1992 | ||
d298c815 LC |
1993 | (match things |
1994 | ((one) | |
1995 | ;; Only one thing; return it. | |
1996 | one) | |
1997 | (_ | |
1998 | (computed-file name | |
1999 | (with-imported-modules '((guix build union)) | |
2000 | (gexp (begin | |
b244ae25 LC |
2001 | (use-modules (guix build union) |
2002 | (srfi srfi-1)) ;for 'first' and 'last' | |
2003 | ||
d298c815 | 2004 | (union-build (ungexp output) |
59523429 LC |
2005 | '(ungexp things) |
2006 | ||
de98b302 | 2007 | #:log-port (ungexp log-port) |
b244ae25 LC |
2008 | #:symlink (ungexp symlink) |
2009 | #:resolve-collision | |
2010 | (ungexp resolve-collision))))))))) | |
d298c815 | 2011 | |
21b679f6 LC |
2012 | \f |
2013 | ;;; | |
2014 | ;;; Syntactic sugar. | |
2015 | ;;; | |
2016 | ||
2017 | (eval-when (expand load eval) | |
667b2508 LC |
2018 | (define* (read-ungexp chr port #:optional native?) |
2019 | "Read an 'ungexp' or 'ungexp-splicing' form from PORT. When NATIVE? is | |
2020 | true, use 'ungexp-native' and 'ungexp-native-splicing' instead." | |
21b679f6 LC |
2021 | (define unquote-symbol |
2022 | (match (peek-char port) | |
2023 | (#\@ | |
2024 | (read-char port) | |
667b2508 LC |
2025 | (if native? |
2026 | 'ungexp-native-splicing | |
2027 | 'ungexp-splicing)) | |
21b679f6 | 2028 | (_ |
667b2508 LC |
2029 | (if native? |
2030 | 'ungexp-native | |
2031 | 'ungexp)))) | |
21b679f6 LC |
2032 | |
2033 | (match (read port) | |
2034 | ((? symbol? symbol) | |
2035 | (let ((str (symbol->string symbol))) | |
2036 | (match (string-index-right str #\:) | |
2037 | (#f | |
2038 | `(,unquote-symbol ,symbol)) | |
2039 | (colon | |
2040 | (let ((name (string->symbol (substring str 0 colon))) | |
2041 | (output (substring str (+ colon 1)))) | |
2042 | `(,unquote-symbol ,name ,output)))))) | |
2043 | (x | |
2044 | `(,unquote-symbol ,x)))) | |
2045 | ||
2046 | (define (read-gexp chr port) | |
2047 | "Read a 'gexp' form from PORT." | |
2048 | `(gexp ,(read port))) | |
2049 | ||
2050 | ;; Extend the reader | |
2051 | (read-hash-extend #\~ read-gexp) | |
667b2508 LC |
2052 | (read-hash-extend #\$ read-ungexp) |
2053 | (read-hash-extend #\+ (cut read-ungexp <> <> #t))) | |
21b679f6 LC |
2054 | |
2055 | ;;; gexp.scm ends here |