guix package: Gracefully handle `official-gnu-packages' failure.
[jackhill/guix/guix.git] / guix / derivations.scm
CommitLineData
233e7676
LC
1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
77d3cf08 3;;;
233e7676 4;;; This file is part of GNU Guix.
77d3cf08 5;;;
233e7676 6;;; GNU Guix is free software; you can redistribute it and/or modify it
77d3cf08
LC
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;;;
233e7676 11;;; GNU Guix is distributed in the hope that it will be useful, but
77d3cf08
LC
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
233e7676 17;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
77d3cf08
LC
18
19(define-module (guix derivations)
20 #:use-module (srfi srfi-1)
21 #:use-module (srfi srfi-9)
22 #:use-module (srfi srfi-26)
23 #:use-module (rnrs io ports)
24 #:use-module (rnrs bytevectors)
25 #:use-module (ice-9 match)
26 #:use-module (ice-9 rdelim)
69f90f5c 27 #:use-module (guix store)
26bbbb95 28 #:use-module (guix utils)
ddc29a78 29 #:use-module (guix base32)
9a20830e
LC
30 #:export (<derivation>
31 derivation?
77d3cf08
LC
32 derivation-outputs
33 derivation-inputs
34 derivation-sources
35 derivation-system
36 derivation-builder-arguments
37 derivation-builder-environment-vars
9a20830e
LC
38 derivation-prerequisites
39 derivation-prerequisites-to-build
77d3cf08 40
9a20830e 41 <derivation-output>
77d3cf08
LC
42 derivation-output?
43 derivation-output-path
44 derivation-output-hash-algo
45 derivation-output-hash
46
9a20830e 47 <derivation-input>
77d3cf08
LC
48 derivation-input?
49 derivation-input-path
50 derivation-input-sub-derivations
51
52 fixed-output-derivation?
341c6fdd
LC
53 derivation-hash
54
55 read-derivation
26bbbb95 56 write-derivation
de4c3f26 57 derivation-path->output-path
7244a5f7 58 derivation-path->output-paths
d9085c23
LC
59 derivation
60
61 %guile-for-build
99634e3f
LC
62 build-expression->derivation
63 imported-files))
77d3cf08
LC
64
65;;;
66;;; Nix derivations, as implemented in Nix's `derivations.cc'.
67;;;
68
69(define-record-type <derivation>
70 (make-derivation outputs inputs sources system builder args env-vars)
71 derivation?
72 (outputs derivation-outputs) ; list of name/<derivation-output> pairs
73 (inputs derivation-inputs) ; list of <derivation-input>
74 (sources derivation-sources) ; list of store paths
75 (system derivation-system) ; string
76 (builder derivation-builder) ; store path
77 (args derivation-builder-arguments) ; list of strings
78 (env-vars derivation-builder-environment-vars)) ; list of name/value pairs
79
80(define-record-type <derivation-output>
81 (make-derivation-output path hash-algo hash)
82 derivation-output?
83 (path derivation-output-path) ; store path
84 (hash-algo derivation-output-hash-algo) ; symbol | #f
749c6567 85 (hash derivation-output-hash)) ; bytevector | #f
77d3cf08
LC
86
87(define-record-type <derivation-input>
88 (make-derivation-input path sub-derivations)
89 derivation-input?
90 (path derivation-input-path) ; store path
91 (sub-derivations derivation-input-sub-derivations)) ; list of strings
92
93(define (fixed-output-derivation? drv)
94 "Return #t if DRV is a fixed-output derivation, such as the result of a
95download with a fixed hash (aka. `fetchurl')."
96 (match drv
97 (($ <derivation>
98 (($ <derivation-output> _ (? symbol?) (? string?))))
99 #t)
100 (_ #f)))
101
9a20830e
LC
102(define (derivation-prerequisites drv)
103 "Return the list of derivation-inputs required to build DRV, recursively."
104 (let loop ((drv drv)
105 (result '()))
106 (let ((inputs (remove (cut member <> result) ; XXX: quadratic
107 (derivation-inputs drv))))
108 (fold loop
109 (append inputs result)
110 (map (lambda (i)
111 (call-with-input-file (derivation-input-path i)
112 read-derivation))
113 inputs)))))
114
784bb1f3
LC
115(define* (derivation-prerequisites-to-build store drv
116 #:key (outputs
117 (map
118 car
119 (derivation-outputs drv))))
120 "Return the list of derivation-inputs required to build the OUTPUTS of
121DRV and not already available in STORE, recursively."
122 (define built?
123 (cut valid-path? store <>))
124
9a20830e
LC
125 (define input-built?
126 (match-lambda
127 (($ <derivation-input> path sub-drvs)
128 (let ((out (map (cut derivation-path->output-path path <>)
129 sub-drvs)))
784bb1f3
LC
130 (any built? out)))))
131
132 (define (derivation-built? drv sub-drvs)
133 (match drv
134 (($ <derivation> outputs)
135 (let ((paths (map (lambda (sub-drv)
136 (derivation-output-path
137 (assoc-ref outputs sub-drv)))
138 sub-drvs)))
139 (every built? paths)))))
140
141 (let loop ((drv drv)
142 (sub-drvs outputs)
143 (result '()))
144 (if (derivation-built? drv sub-drvs)
145 result
146 (let ((inputs (remove (lambda (i)
147 (or (member i result) ; XXX: quadratic
148 (input-built? i)))
149 (derivation-inputs drv))))
150 (fold loop
151 (append inputs result)
152 (map (lambda (i)
153 (call-with-input-file (derivation-input-path i)
154 read-derivation))
155 inputs)
156 (map derivation-input-sub-derivations inputs))))))
9a20830e 157
d0840e4a
LC
158(define (%read-derivation drv-port)
159 ;; Actually read derivation from DRV-PORT.
77d3cf08
LC
160
161 (define comma (string->symbol ","))
162
163 (define (ununquote x)
164 (match x
165 (('unquote x) (ununquote x))
166 ((x ...) (map ununquote x))
167 (_ x)))
168
169 (define (outputs->alist x)
170 (fold-right (lambda (output result)
171 (match output
172 ((name path "" "")
173 (alist-cons name
174 (make-derivation-output path #f #f)
175 result))
176 ((name path hash-algo hash)
177 ;; fixed-output
749c6567
LC
178 (let ((algo (string->symbol hash-algo))
179 (hash (base16-string->bytevector hash)))
77d3cf08
LC
180 (alist-cons name
181 (make-derivation-output path algo hash)
182 result)))))
183 '()
184 x))
185
186 (define (make-input-drvs x)
187 (fold-right (lambda (input result)
188 (match input
189 ((path (sub-drvs ...))
190 (cons (make-derivation-input path sub-drvs)
191 result))))
192 '()
193 x))
194
df7bbd38
LC
195 ;; The contents of a derivation are typically ASCII, but choosing
196 ;; UTF-8 allows us to take the fast path for Guile's `scm_getc'.
197 (set-port-encoding! drv-port "UTF-8")
198
77d3cf08
LC
199 (let loop ((exp (read drv-port))
200 (result '()))
201 (match exp
202 ((? eof-object?)
203 (let ((result (reverse result)))
204 (match result
205 (('Derive ((outputs ...) (input-drvs ...)
206 (input-srcs ...)
207 (? string? system)
208 (? string? builder)
209 ((? string? args) ...)
210 ((var value) ...)))
211 (make-derivation (outputs->alist outputs)
212 (make-input-drvs input-drvs)
213 input-srcs
214 system builder args
215 (fold-right alist-cons '() var value)))
216 (_
217 (error "failed to parse derivation" drv-port result)))))
218 ((? (cut eq? <> comma))
219 (loop (read drv-port) result))
220 (_
221 (loop (read drv-port)
222 (cons (ununquote exp) result))))))
223
d0840e4a
LC
224(define read-derivation
225 (let ((cache (make-weak-value-hash-table 200)))
226 (lambda (drv-port)
227 "Read the derivation from DRV-PORT and return the corresponding
228<derivation> object."
229 ;; Memoize that operation because `%read-derivation' is quite expensive,
230 ;; and because the same argument is read more than 15 times on average
231 ;; during something like (package-derivation s gdb).
232 (let ((file (and=> (port-filename drv-port) basename)))
233 (or (and file (hash-ref cache file))
234 (let ((drv (%read-derivation drv-port)))
235 (hash-set! cache file drv)
236 drv))))))
237
77d3cf08
LC
238(define (write-derivation drv port)
239 "Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of
240Eelco Dolstra's PhD dissertation for an overview of a previous version of
241that form."
aaa848f3
LC
242
243 ;; Make sure we're using the faster implementation.
244 (define format simple-format)
245
77d3cf08
LC
246 (define (list->string lst)
247 (string-append "[" (string-join lst ",") "]"))
248
249 (define (write-list lst)
250 (display (list->string lst) port))
251
d66ac374
LC
252 (define (coalesce-duplicate-inputs inputs)
253 ;; Return a list of inputs, such that when INPUTS contains the same DRV
254 ;; twice, they are coalesced, with their sub-derivations merged. This is
255 ;; needed because Nix itself keeps only one of them.
256 (fold (lambda (input result)
257 (match input
258 (($ <derivation-input> path sub-drvs)
259 ;; XXX: quadratic
260 (match (find (match-lambda
261 (($ <derivation-input> p s)
262 (string=? p path)))
263 result)
264 (#f
265 (cons input result))
266 ((and dup ($ <derivation-input> _ sub-drvs2))
267 ;; Merge DUP with INPUT.
268 (let ((sub-drvs (delete-duplicates
269 (append sub-drvs sub-drvs2))))
270 (cons (make-derivation-input path sub-drvs)
271 (delq dup result))))))))
272 '()
273 inputs))
274
561eaf71
LC
275 ;; Note: lists are sorted alphabetically, to conform with the behavior of
276 ;; C++ `std::map' in Nix itself.
277
77d3cf08
LC
278 (match drv
279 (($ <derivation> outputs inputs sources
280 system builder args env-vars)
281 (display "Derive(" port)
282 (write-list (map (match-lambda
283 ((name . ($ <derivation-output> path hash-algo hash))
284 (format #f "(~s,~s,~s,~s)"
749c6567
LC
285 name path
286 (or (and=> hash-algo symbol->string) "")
287 (or (and=> hash bytevector->base16-string)
288 ""))))
561eaf71
LC
289 (sort outputs
290 (lambda (o1 o2)
291 (string<? (car o1) (car o2))))))
77d3cf08
LC
292 (display "," port)
293 (write-list (map (match-lambda
294 (($ <derivation-input> path sub-drvs)
295 (format #f "(~s,~a)" path
561eaf71
LC
296 (list->string (map object->string
297 (sort sub-drvs string<?))))))
d66ac374 298 (sort (coalesce-duplicate-inputs inputs)
561eaf71
LC
299 (lambda (i1 i2)
300 (string<? (derivation-input-path i1)
301 (derivation-input-path i2))))))
77d3cf08 302 (display "," port)
561eaf71 303 (write-list (map object->string (sort sources string<?)))
77d3cf08
LC
304 (format port ",~s,~s," system builder)
305 (write-list (map object->string args))
306 (display "," port)
307 (write-list (map (match-lambda
308 ((name . value)
309 (format #f "(~s,~s)" name value)))
561eaf71
LC
310 (sort env-vars
311 (lambda (e1 e2)
312 (string<? (car e1) (car e2))))))
77d3cf08
LC
313 (display ")" port))))
314
aaa848f3
LC
315(define derivation-path->output-path
316 ;; This procedure is called frequently, so memoize it.
317 (memoize
318 (lambda* (path #:optional (output "out"))
319 "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store
de4c3f26 320path of its output OUTPUT."
aaa848f3
LC
321 (let* ((drv (call-with-input-file path read-derivation))
322 (outputs (derivation-outputs drv)))
323 (and=> (assoc-ref outputs output) derivation-output-path)))))
de4c3f26 324
7244a5f7
LC
325(define (derivation-path->output-paths path)
326 "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the
327list of name/path pairs of its outputs."
328 (let* ((drv (call-with-input-file path read-derivation))
329 (outputs (derivation-outputs drv)))
330 (map (match-lambda
331 ((name . output)
332 (cons name (derivation-output-path output))))
333 outputs)))
334
de4c3f26
LC
335\f
336;;;
337;;; Derivation primitive.
338;;;
339
26bbbb95
LC
340(define (compressed-hash bv size) ; `compressHash'
341 "Given the hash stored in BV, return a compressed version thereof that fits
342in SIZE bytes."
343 (define new (make-bytevector size 0))
344 (define old-size (bytevector-length bv))
345 (let loop ((i 0))
346 (if (= i old-size)
347 new
348 (let* ((j (modulo i size))
349 (o (bytevector-u8-ref new j)))
350 (bytevector-u8-set! new j
351 (logxor o (bytevector-u8-ref bv i)))
352 (loop (+ 1 i))))))
77d3cf08 353
de4c3f26
LC
354(define derivation-hash ; `hashDerivationModulo' in derivations.cc
355 (memoize
356 (lambda (drv)
357 "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
358 (match drv
359 (($ <derivation> ((_ . ($ <derivation-output> path
749c6567 360 (? symbol? hash-algo) (? bytevector? hash)))))
de4c3f26 361 ;; A fixed-output derivation.
77d3cf08 362 (sha256
de4c3f26
LC
363 (string->utf8
364 (string-append "fixed:out:" (symbol->string hash-algo)
749c6567
LC
365 ":" (bytevector->base16-string hash)
366 ":" path))))
de4c3f26
LC
367 (($ <derivation> outputs inputs sources
368 system builder args env-vars)
369 ;; A regular derivation: replace the path of each input with that
370 ;; input's hash; return the hash of serialization of the resulting
561eaf71
LC
371 ;; derivation.
372 (let* ((inputs (map (match-lambda
373 (($ <derivation-input> path sub-drvs)
374 (let ((hash (call-with-input-file path
375 (compose bytevector->base16-string
376 derivation-hash
377 read-derivation))))
378 (make-derivation-input hash sub-drvs))))
379 inputs))
380 (drv (make-derivation outputs inputs sources
381 system builder args env-vars)))
de4c3f26
LC
382 (sha256
383 (string->utf8 (call-with-output-string
384 (cut write-derivation drv <>))))))))))
77d3cf08 385
26bbbb95
LC
386(define (store-path type hash name) ; makeStorePath
387 "Return the store path for NAME/HASH/TYPE."
388 (let* ((s (string-append type ":sha256:"
389 (bytevector->base16-string hash) ":"
390 (%store-prefix) ":" name))
391 (h (sha256 (string->utf8 s)))
392 (c (compressed-hash h 20)))
393 (string-append (%store-prefix) "/"
394 (bytevector->nix-base32-string c) "-"
395 name)))
396
397(define (output-path output hash name) ; makeOutputPath
398 "Return an output path for OUTPUT (the name of the output as a string) of
399the derivation called NAME with hash HASH."
400 (store-path (string-append "output:" output) hash
401 (if (string=? output "out")
402 name
403 (string-append name "-" output))))
404
405(define* (derivation store name system builder args env-vars inputs
406 #:key (outputs '("out")) hash hash-algo hash-mode)
407 "Build a derivation with the given arguments. Return the resulting
fb3eec83 408store path and <derivation> object. When HASH, HASH-ALGO, and HASH-MODE
26bbbb95
LC
409are given, a fixed-output derivation is created---i.e., one whose result is
410known in advance, such as a file download."
200dc937
LC
411 (define direct-store-path?
412 (let ((len (+ 1 (string-length (%store-prefix)))))
413 (lambda (p)
414 ;; Return #t if P is a store path, and not a sub-directory of a
415 ;; store path. This predicate is needed because files *under* a
416 ;; store path are not valid inputs.
417 (and (store-path? p)
418 (not (string-index (substring p len) #\/))))))
419
26bbbb95
LC
420 (define (add-output-paths drv)
421 ;; Return DRV with an actual store path for each of its output and the
422 ;; corresponding environment variable.
423 (match drv
424 (($ <derivation> outputs inputs sources
425 system builder args env-vars)
426 (let* ((drv-hash (derivation-hash drv))
427 (outputs (map (match-lambda
d9085c23
LC
428 ((output-name . ($ <derivation-output>
429 _ algo hash))
430 (let ((path (output-path output-name
431 drv-hash name)))
432 (cons output-name
433 (make-derivation-output path algo
434 hash)))))
435 outputs)))
26bbbb95
LC
436 (make-derivation outputs inputs sources system builder args
437 (map (match-lambda
438 ((name . value)
439 (cons name
440 (or (and=> (assoc-ref outputs name)
441 derivation-output-path)
442 value))))
443 env-vars))))))
444
445 (define (env-vars-with-empty-outputs)
446 ;; Return a variant of ENV-VARS where each OUTPUTS is associated with an
561eaf71 447 ;; empty string, even outputs that do not appear in ENV-VARS.
26bbbb95
LC
448 (let ((e (map (match-lambda
449 ((name . val)
450 (if (member name outputs)
451 (cons name "")
452 (cons name val))))
453 env-vars)))
561eaf71
LC
454 (fold (lambda (output-name env-vars)
455 (if (assoc output-name env-vars)
456 env-vars
457 (append env-vars `((,output-name . "")))))
458 e
459 outputs)))
26bbbb95
LC
460
461 (let* ((outputs (map (lambda (name)
462 ;; Return outputs with an empty path.
463 (cons name
464 (make-derivation-output "" hash-algo hash)))
465 outputs))
466 (inputs (map (match-lambda
200dc937 467 (((? direct-store-path? input))
de4c3f26 468 (make-derivation-input input '("out")))
200dc937 469 (((? direct-store-path? input) sub-drvs ...)
26bbbb95
LC
470 (make-derivation-input input sub-drvs))
471 ((input . _)
472 (let ((path (add-to-store store
473 (basename input)
a9ebd9ef 474 #t "sha256" input)))
26bbbb95 475 (make-derivation-input path '()))))
d26ad5e4 476 (delete-duplicates inputs)))
26bbbb95
LC
477 (env-vars (env-vars-with-empty-outputs))
478 (drv-masked (make-derivation outputs
479 (filter (compose derivation-path?
480 derivation-input-path)
481 inputs)
482 (filter-map (lambda (i)
483 (let ((p (derivation-input-path i)))
484 (and (not (derivation-path? p))
485 p)))
486 inputs)
487 system builder args env-vars))
488 (drv (add-output-paths drv-masked)))
de4c3f26 489
d66ac374
LC
490 ;; (write-derivation drv-masked (current-error-port))
491 ;; (newline (current-error-port))
fb3eec83
LC
492 (values (add-text-to-store store (string-append name ".drv")
493 (call-with-output-string
494 (cut write-derivation drv <>))
495 (map derivation-input-path
496 inputs))
497 drv)))
d9085c23
LC
498
499\f
500;;;
501;;; Guile-based builders.
502;;;
503
504(define %guile-for-build
505 ;; The derivation of the Guile to be used within the build environment,
506 ;; when using `build-expression->derivation'.
b272c474 507 (make-parameter #f))
d9085c23 508
d9024884
LC
509(define (parent-directories file-name)
510 "Return the list of parent dirs of FILE-NAME, in the order in which an
511`mkdir -p' implementation would make them."
512 (let ((not-slash (char-set-complement (char-set #\/))))
513 (reverse
514 (fold (lambda (dir result)
515 (match result
516 (()
517 (list dir))
518 ((prev _ ...)
519 (cons (string-append prev "/" dir)
520 result))))
521 '()
522 (remove (cut string=? <> ".")
523 (string-tokenize (dirname file-name) not-slash))))))
524
99634e3f 525(define* (imported-files store files
b272c474
LC
526 #:key (name "file-import")
527 (system (%current-system))
528 (guile (%guile-for-build)))
99634e3f
LC
529 "Return a derivation that imports FILES into STORE. FILES must be a list
530of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file
531system, imported, and appears under FINAL-PATH in the resulting store path."
99634e3f
LC
532 (let* ((files (map (match-lambda
533 ((final-path . file-name)
2acb2cb6 534 (list final-path
a9ebd9ef 535 (add-to-store store (basename final-path) #f
99634e3f
LC
536 "sha256" file-name))))
537 files))
538 (builder
539 `(begin
540 (mkdir %output) (chdir %output)
541 ,@(append-map (match-lambda
2acb2cb6 542 ((final-path store-path)
d9024884 543 (append (match (parent-directories final-path)
99634e3f
LC
544 (() '())
545 ((head ... tail)
546 (append (map (lambda (d)
547 `(false-if-exception
548 (mkdir ,d)))
549 head)
224f7ad6
LC
550 `((or (file-exists? ,tail)
551 (mkdir ,tail))))))
99634e3f
LC
552 `((symlink ,store-path ,final-path)))))
553 files))))
ae39d1b2 554 (build-expression->derivation store name system
b272c474
LC
555 builder files
556 #:guile-for-build guile)))
99634e3f 557
3eb98237
LC
558(define* (imported-modules store modules
559 #:key (name "module-import")
b272c474 560 (system (%current-system))
8dcb0c55
LC
561 (guile (%guile-for-build))
562 (module-path %load-path))
3eb98237 563 "Return a derivation that contains the source files of MODULES, a list of
8dcb0c55 564module names such as `(ice-9 q)'. All of MODULES must be in the MODULE-PATH
3eb98237
LC
565search path."
566 ;; TODO: Determine the closure of MODULES, build the `.go' files,
567 ;; canonicalize the source files through read/write, etc.
568 (let ((files (map (lambda (m)
569 (let ((f (string-append
570 (string-join (map symbol->string m) "/")
571 ".scm")))
8dcb0c55 572 (cons f (search-path module-path f))))
3eb98237 573 modules)))
b272c474
LC
574 (imported-files store files #:name name #:system system
575 #:guile guile)))
3eb98237 576
d9024884
LC
577(define* (compiled-modules store modules
578 #:key (name "module-import-compiled")
b272c474 579 (system (%current-system))
8dcb0c55
LC
580 (guile (%guile-for-build))
581 (module-path %load-path))
d9024884
LC
582 "Return a derivation that builds a tree containing the `.go' files
583corresponding to MODULES. All the MODULES are built in a context where
584they can refer to each other."
585 (let* ((module-drv (imported-modules store modules
b272c474 586 #:system system
8dcb0c55
LC
587 #:guile guile
588 #:module-path module-path))
d9024884
LC
589 (module-dir (derivation-path->output-path module-drv))
590 (files (map (lambda (m)
591 (let ((f (string-join (map symbol->string m)
592 "/")))
593 (cons (string-append f ".go")
594 (string-append module-dir "/" f ".scm"))))
595 modules)))
596 (define builder
597 `(begin
598 (use-modules (system base compile))
599 (let ((out (assoc-ref %outputs "out")))
600 (mkdir out)
601 (chdir out))
602
603 (set! %load-path
604 (cons ,module-dir %load-path))
605
606 ,@(map (match-lambda
607 ((output . input)
608 (let ((make-parent-dirs (map (lambda (dir)
609 `(unless (file-exists? ,dir)
610 (mkdir ,dir)))
611 (parent-directories output))))
612 `(begin
613 ,@make-parent-dirs
614 (compile-file ,input
615 #:output-file ,output
616 #:opts %auto-compilation-options)))))
617 files)))
618
619 (build-expression->derivation store name system builder
b272c474
LC
620 `(("modules" ,module-drv))
621 #:guile-for-build guile)))
3eb98237 622
d9085c23 623(define* (build-expression->derivation store name system exp inputs
9bc07f4d 624 #:key (outputs '("out"))
3eb98237 625 hash hash-algo
4c1eddf7 626 (env-vars '())
6dd7787c
LC
627 (modules '())
628 guile-for-build)
874e6874
LC
629 "Return a derivation that executes Scheme expression EXP as a builder
630for derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV)
631tuples; when SUB-DRV is omitted, \"out\" is assumed. MODULES is a list
632of names of Guile modules from the current search path to be copied in
633the store, compiled, and made available in the load path during the
634execution of EXP.
635
636EXP is evaluated in an environment where %OUTPUT is bound to the main
637output path, %OUTPUTS is bound to a list of output/path pairs, and where
638%BUILD-INPUTS is bound to an alist of string/output-path pairs made from
639INPUTS. Optionally, ENV-VARS is a list of string pairs specifying the
640name and value of environment variables visible to the builder. The
641builder terminates by passing the result of EXP to `exit'; thus, when
642EXP returns #f, the build is considered to have failed.
6dd7787c
LC
643
644EXP is built using GUILE-FOR-BUILD (a derivation). When GUILE-FOR-BUILD is
645omitted or is #f, the value of the `%guile-for-build' fluid is used instead."
b272c474
LC
646 (define guile-drv
647 (or guile-for-build (%guile-for-build)))
648
d9085c23 649 (define guile
b272c474 650 (string-append (derivation-path->output-path guile-drv)
d9085c23
LC
651 "/bin/guile"))
652
0d56a551
LC
653 (define module-form?
654 (match-lambda
655 (((or 'define-module 'use-modules) _ ...) #t)
656 (_ #f)))
657
7bdd1f0e
LC
658 (define source-path
659 ;; When passed an input that is a source, return its path; otherwise
660 ;; return #f.
661 (match-lambda
662 ((_ path _ ...)
663 (and (not (derivation-path? path))
664 path))))
665
d9085c23 666 (let* ((prologue `(begin
0d56a551
LC
667 ,@(match exp
668 ((_ ...)
669 ;; Module forms must appear at the top-level so
670 ;; that any macros they export can be expanded.
671 (filter module-form? exp))
672 (_ `(,exp)))
673
d9085c23 674 (define %output (getenv "out"))
9bc07f4d
LC
675 (define %outputs
676 (map (lambda (o)
677 (cons o (getenv o)))
678 ',outputs))
d9085c23
LC
679 (define %build-inputs
680 ',(map (match-lambda
2acb2cb6
LC
681 ((name drv . rest)
682 (let ((sub (match rest
683 (() "out")
684 ((x) x))))
685 (cons name
686 (if (derivation-path? drv)
687 (derivation-path->output-path drv
688 sub)
689 drv)))))
d44bc84b
LC
690 inputs))
691
d9024884
LC
692 ,@(if (null? modules)
693 '()
694 ;; Remove our own settings.
695 '((unsetenv "GUILE_LOAD_COMPILED_PATH")))
696
d44bc84b
LC
697 ;; Guile sets it, but remove it to avoid conflicts when
698 ;; building Guile-using packages.
699 (unsetenv "LD_LIBRARY_PATH")))
d9085c23
LC
700 (builder (add-text-to-store store
701 (string-append name "-guile-builder")
0d56a551
LC
702 (string-append
703 (object->string prologue)
704 (object->string
705 `(exit
706 ,(match exp
707 ((_ ...)
708 (remove module-form? exp))
709 (_ `(,exp))))))
7bdd1f0e
LC
710
711 ;; The references don't really matter
712 ;; since the builder is always used in
713 ;; conjunction with the drv that needs
714 ;; it. For clarity, we add references
715 ;; to the subset of INPUTS that are
716 ;; sources, avoiding references to other
717 ;; .drv; otherwise, BUILDER's hash would
718 ;; depend on those, even if they are
719 ;; fixed-output.
720 (filter-map source-path inputs)))
721
d9024884 722 (mod-drv (and (pair? modules)
ae39d1b2
LC
723 (imported-modules store modules
724 #:guile guile-drv
725 #:system system)))
3eb98237 726 (mod-dir (and mod-drv
d9024884
LC
727 (derivation-path->output-path mod-drv)))
728 (go-drv (and (pair? modules)
ae39d1b2
LC
729 (compiled-modules store modules
730 #:guile guile-drv
731 #:system system)))
d9024884
LC
732 (go-dir (and go-drv
733 (derivation-path->output-path go-drv))))
3eb98237
LC
734 (derivation store name system guile
735 `("--no-auto-compile"
736 ,@(if mod-dir `("-L" ,mod-dir) '())
737 ,builder)
d9024884
LC
738
739 ;; When MODULES is non-empty, shamelessly clobber
740 ;; $GUILE_LOAD_COMPILED_PATH.
741 (if go-dir
742 `(("GUILE_LOAD_COMPILED_PATH" . ,go-dir)
743 ,@(alist-delete "GUILE_LOAD_COMPILED_PATH"
744 env-vars))
745 env-vars)
746
6dd7787c 747 `((,(or guile-for-build (%guile-for-build)))
3eb98237 748 (,builder)
2acb2cb6 749 ,@(map cdr inputs)
d9024884 750 ,@(if mod-drv `((,mod-drv) (,go-drv)) '()))
9bc07f4d
LC
751 #:hash hash #:hash-algo hash-algo
752 #:outputs outputs)))