| blob | 1929947d95dbe60bbc1124ffd9a6bd6f28f19368 |
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
3 ;;;
4 ;;; This file is part of GNU Guix.
5 ;;;
6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
10 ;;;
11 ;;; GNU Guix is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19 (define-module (guix gexp)
20 #:use-module (guix store)
21 #:use-module (guix monads)
22 #:use-module (guix derivations)
23 #:use-module (guix grafts)
24 #:use-module (guix utils)
25 #:use-module (srfi srfi-1)
26 #:use-module (srfi srfi-9)
27 #:use-module (srfi srfi-9 gnu)
28 #:use-module (srfi srfi-26)
29 #:use-module (srfi srfi-34)
30 #:use-module (srfi srfi-35)
31 #:use-module (ice-9 match)
32 #:export (gexp
33 gexp?
34 with-imported-modules
36 gexp-input
37 gexp-input?
39 local-file
40 local-file?
41 local-file-file
42 local-file-absolute-file-name
43 local-file-name
44 local-file-recursive?
46 plain-file
47 plain-file?
48 plain-file-name
49 plain-file-content
51 computed-file
52 computed-file?
53 computed-file-name
54 computed-file-gexp
55 computed-file-options
57 program-file
58 program-file?
59 program-file-name
60 program-file-gexp
61 program-file-guile
63 scheme-file
64 scheme-file?
65 scheme-file-name
66 scheme-file-gexp
68 file-append
69 file-append?
70 file-append-base
71 file-append-suffix
73 load-path-expression
74 gexp-modules
76 gexp->derivation
77 gexp->file
78 gexp->script
79 text-file*
80 mixed-text-file
81 file-union
82 directory-union
83 imported-files
84 imported-modules
85 compiled-modules
87 define-gexp-compiler
88 gexp-compiler?
89 lower-object
91 lower-inputs
93 &gexp-error
94 gexp-error?
95 &gexp-input-error
96 gexp-input-error?
97 gexp-error-invalid-input))
99 ;;; Commentary:
100 ;;;
101 ;;; This module implements "G-expressions", or "gexps". Gexps are like
102 ;;; S-expressions (sexps), with two differences:
103 ;;;
104 ;;; 1. References (un-quotations) to derivations or packages in a gexp are
105 ;;; replaced by the corresponding output file name; in addition, the
106 ;;; 'ungexp-native' unquote-like form allows code to explicitly refer to
107 ;;; the native code of a given package, in case of cross-compilation;
108 ;;;
109 ;;; 2. Gexps embed information about the derivations they refer to.
110 ;;;
111 ;;; Gexps make it easy to write to files Scheme code that refers to store
112 ;;; items, or to write Scheme code to build derivations.
113 ;;;
114 ;;; Code:
116 ;; "G expressions".
117 (define-record-type <gexp>
118 (make-gexp references modules proc)
119 gexp?
120 (references gexp-references) ;list of <gexp-input>
121 (modules gexp-self-modules) ;list of module names
122 (proc gexp-proc)) ;procedure
124 (define (write-gexp gexp port)
125 "Write GEXP on PORT."
126 (display "#<gexp " port)
128 ;; Try to write the underlying sexp. Now, this trick doesn't work when
129 ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure
130 ;; tries to use 'append' on that, which fails with wrong-type-arg.
131 (false-if-exception
132 (write (apply (gexp-proc gexp)
133 (gexp-references gexp))
134 port))
135 (format port " ~a>"
136 (number->string (object-address gexp) 16)))
138 (set-record-type-printer! <gexp> write-gexp)
140 \f
141 ;;;
142 ;;; Methods.
143 ;;;
145 ;; Compiler for a type of objects that may be introduced in a gexp.
146 (define-record-type <gexp-compiler>
147 (gexp-compiler type lower expand)
148 gexp-compiler?
149 (type gexp-compiler-type) ;record type descriptor
150 (lower gexp-compiler-lower)
151 (expand gexp-compiler-expand)) ;#f | DRV -> sexp
153 (define-condition-type &gexp-error &error
154 gexp-error?)
156 (define-condition-type &gexp-input-error &gexp-error
157 gexp-input-error?
158 (input gexp-error-invalid-input))
161 (define %gexp-compilers
162 ;; 'eq?' mapping of record type descriptor to <gexp-compiler>.
163 (make-hash-table 20))
165 (define (default-expander thing obj output)
166 "This is the default expander for \"things\" that appear in gexps. It
167 returns its output file name of OBJ's OUTPUT."
168 (match obj
169 ((? derivation? drv)
170 (derivation->output-path drv output))
171 ((? string? file)
172 file)))
174 (define (register-compiler! compiler)
175 "Register COMPILER as a gexp compiler."
176 (hashq-set! %gexp-compilers
177 (gexp-compiler-type compiler) compiler))
179 (define (lookup-compiler object)
180 "Search for a compiler for OBJECT. Upon success, return the three argument
181 procedure to lower it; otherwise return #f."
182 (and=> (hashq-ref %gexp-compilers (struct-vtable object))
183 gexp-compiler-lower))
185 (define (lookup-expander object)
186 "Search for an expander for OBJECT. Upon success, return the three argument
187 procedure to expand it; otherwise return #f."
188 (and=> (hashq-ref %gexp-compilers (struct-vtable object))
189 gexp-compiler-expand))
191 (define* (lower-object obj
192 #:optional (system (%current-system))
193 #:key target)
194 "Return as a value in %STORE-MONAD the derivation or store item
195 corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
196 OBJ must be an object that has an associated gexp compiler, such as a
197 <package>."
198 (match (lookup-compiler obj)
199 (#f
200 (raise (condition (&gexp-input-error (input obj)))))
201 (lower
202 (lower obj system target))))
204 (define-syntax define-gexp-compiler
205 (syntax-rules (=> compiler expander)
206 "Define NAME as a compiler for objects matching PREDICATE encountered in
207 gexps.
209 In the simplest form of the macro, BODY must return a derivation for PARAM, an
210 object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is
211 #f except when cross-compiling.)
213 The more elaborate form allows you to specify an expander:
215 (define-gexp-compiler something something?
216 compiler => (lambda (param system target) ...)
217 expander => (lambda (param drv output) ...))
219 The expander specifies how an object is converted to its sexp representation."
220 ((_ (name (param record-type) system target) body ...)
221 (define-gexp-compiler name record-type
222 compiler => (lambda (param system target) body ...)
223 expander => default-expander))
224 ((_ name record-type
225 compiler => compile
226 expander => expand)
227 (begin
228 (define name
229 (gexp-compiler record-type compile expand))
230 (register-compiler! name)))))
232 (define-gexp-compiler (derivation-compiler (drv <derivation>) system target)
233 ;; Derivations are the lowest-level representation, so this is the identity
234 ;; compiler.
235 (with-monad %store-monad
236 (return drv)))
238 \f
239 ;;;
240 ;;; File declarations.
241 ;;;
243 ;; A local file name. FILE is the file name the user entered, which can be a
244 ;; relative file name, and ABSOLUTE is a promise that computes its canonical
245 ;; absolute file name. We keep it in a promise to compute it lazily and avoid
246 ;; repeated 'stat' calls.
247 (define-record-type <local-file>
248 (%%local-file file absolute name recursive? select?)
249 local-file?
250 (file local-file-file) ;string
251 (absolute %local-file-absolute-file-name) ;promise string
252 (name local-file-name) ;string
253 (recursive? local-file-recursive?) ;Boolean
254 (select? local-file-select?)) ;string stat -> Boolean
256 (define (true file stat) #t)
258 (define* (%local-file file promise #:optional (name (basename file))
259 #:key recursive? (select? true))
260 ;; This intermediate procedure is part of our ABI, but the underlying
261 ;; %%LOCAL-FILE is not.
262 (%%local-file file promise name recursive? select?))
264 (define (absolute-file-name file directory)
265 "Return the canonical absolute file name for FILE, which lives in the
266 vicinity of DIRECTORY."
267 (canonicalize-path
268 (cond ((string-prefix? "/" file) file)
269 ((not directory) file)
270 ((string-prefix? "/" directory)
271 (string-append directory "/" file))
272 (else file))))
274 (define-syntax local-file
275 (lambda (s)
276 "Return an object representing local file FILE to add to the store; this
277 object can be used in a gexp. If FILE is a relative file name, it is looked
278 up relative to the source file where this form appears. FILE will be added to
279 the store under NAME--by default the base name of FILE.
281 When RECURSIVE? is true, the contents of FILE are added recursively; if FILE
282 designates a flat file and RECURSIVE? is true, its contents are added, and its
283 permission bits are kept.
285 When RECURSIVE? is true, call (SELECT? FILE STAT) for each directory entry,
286 where FILE is the entry's absolute file name and STAT is the result of
287 'lstat'; exclude entries for which SELECT? does not return true.
289 This is the declarative counterpart of the 'interned-file' monadic procedure.
290 It is implemented as a macro to capture the current source directory where it
291 appears."
292 (syntax-case s ()
293 ((_ file rest ...)
294 #'(%local-file file
295 (delay (absolute-file-name file (current-source-directory)))
296 rest ...))
297 ((_)
298 #'(syntax-error "missing file name"))
299 (id
300 (identifier? #'id)
301 ;; XXX: We could return #'(lambda (file . rest) ...). However,
302 ;; (syntax-source #'id) is #f so (current-source-directory) would not
303 ;; work. Thus, simply forbid this form.
304 #'(syntax-error
305 "'local-file' is a macro and cannot be used like this")))))
307 (define (local-file-absolute-file-name file)
308 "Return the absolute file name for FILE, a <local-file> instance. A
309 'system-error' exception is raised if FILE could not be found."
310 (force (%local-file-absolute-file-name file)))
312 (define-gexp-compiler (local-file-compiler (file <local-file>) system target)
313 ;; "Compile" FILE by adding it to the store.
314 (match file
315 (($ <local-file> file (= force absolute) name recursive? select?)
316 ;; Canonicalize FILE so that if it's a symlink, it is resolved. Failing
317 ;; to do that, when RECURSIVE? is #t, we could end up creating a dangling
318 ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would
319 ;; just throw an error, both of which are inconvenient.
320 (interned-file absolute name
321 #:recursive? recursive? #:select? select?))))
323 (define-record-type <plain-file>
324 (%plain-file name content references)
325 plain-file?
326 (name plain-file-name) ;string
327 (content plain-file-content) ;string
328 (references plain-file-references)) ;list (currently unused)
330 (define (plain-file name content)
331 "Return an object representing a text file called NAME with the given
332 CONTENT (a string) to be added to the store.
334 This is the declarative counterpart of 'text-file'."
335 ;; XXX: For now just ignore 'references' because it's not clear how to use
336 ;; them in a declarative context.
337 (%plain-file name content '()))
339 (define-gexp-compiler (plain-file-compiler (file <plain-file>) system target)
340 ;; "Compile" FILE by adding it to the store.
341 (match file
342 (($ <plain-file> name content references)
343 (text-file name content references))))
345 (define-record-type <computed-file>
346 (%computed-file name gexp options)
347 computed-file?
348 (name computed-file-name) ;string
349 (gexp computed-file-gexp) ;gexp
350 (options computed-file-options)) ;list of arguments
352 (define* (computed-file name gexp
353 #:key (options '(#:local-build? #t)))
354 "Return an object representing the store item NAME, a file or directory
355 computed by GEXP. OPTIONS is a list of additional arguments to pass
356 to 'gexp->derivation'.
358 This is the declarative counterpart of 'gexp->derivation'."
359 (%computed-file name gexp options))
361 (define-gexp-compiler (computed-file-compiler (file <computed-file>)
362 system target)
363 ;; Compile FILE by returning a derivation whose build expression is its
364 ;; gexp.
365 (match file
366 (($ <computed-file> name gexp options)
367 (apply gexp->derivation name gexp options))))
369 (define-record-type <program-file>
370 (%program-file name gexp guile)
371 program-file?
372 (name program-file-name) ;string
373 (gexp program-file-gexp) ;gexp
374 (guile program-file-guile)) ;package
376 (define* (program-file name gexp #:key (guile #f))
377 "Return an object representing the executable store item NAME that runs
378 GEXP. GUILE is the Guile package used to execute that script.
380 This is the declarative counterpart of 'gexp->script'."
381 (%program-file name gexp guile))
383 (define-gexp-compiler (program-file-compiler (file <program-file>)
384 system target)
385 ;; Compile FILE by returning a derivation that builds the script.
386 (match file
387 (($ <program-file> name gexp guile)
388 (gexp->script name gexp
389 #:guile (or guile (default-guile))))))
391 (define-record-type <scheme-file>
392 (%scheme-file name gexp)
393 scheme-file?
394 (name scheme-file-name) ;string
395 (gexp scheme-file-gexp)) ;gexp
397 (define* (scheme-file name gexp)
398 "Return an object representing the Scheme file NAME that contains GEXP.
400 This is the declarative counterpart of 'gexp->file'."
401 (%scheme-file name gexp))
403 (define-gexp-compiler (scheme-file-compiler (file <scheme-file>)
404 system target)
405 ;; Compile FILE by returning a derivation that builds the file.
406 (match file
407 (($ <scheme-file> name gexp)
408 (gexp->file name gexp))))
410 ;; Appending SUFFIX to BASE's output file name.
411 (define-record-type <file-append>
412 (%file-append base suffix)
413 file-append?
414 (base file-append-base) ;<package> | <derivation> | ...
415 (suffix file-append-suffix)) ;list of strings
417 (define (file-append base . suffix)
418 "Return a <file-append> object that expands to the concatenation of BASE and
419 SUFFIX."
420 (%file-append base suffix))
422 (define-gexp-compiler file-append-compiler <file-append>
423 compiler => (lambda (obj system target)
424 (match obj
425 (($ <file-append> base _)
426 (lower-object base system #:target target))))
427 expander => (lambda (obj lowered output)
428 (match obj
429 (($ <file-append> base suffix)
430 (let* ((expand (lookup-expander base))
431 (base (expand base lowered output)))
432 (string-append base (string-concatenate suffix)))))))
434 \f
435 ;;;
436 ;;; Inputs & outputs.
437 ;;;
439 ;; The input of a gexp.
440 (define-record-type <gexp-input>
441 (%gexp-input thing output native?)
442 gexp-input?
443 (thing gexp-input-thing) ;<package> | <origin> | <derivation> | ...
444 (output gexp-input-output) ;string
445 (native? gexp-input-native?)) ;Boolean
447 (define (write-gexp-input input port)
448 (match input
449 (($ <gexp-input> thing output #f)
450 (format port "#<gexp-input ~s:~a>" thing output))
451 (($ <gexp-input> thing output #t)
452 (format port "#<gexp-input native ~s:~a>" thing output))))
454 (set-record-type-printer! <gexp-input> write-gexp-input)
456 (define* (gexp-input thing ;convenience procedure
457 #:optional (output "out")
458 #:key native?)
459 "Return a new <gexp-input> for the OUTPUT of THING; NATIVE? determines
460 whether this should be considered a \"native\" input or not."
461 (%gexp-input thing output native?))
463 ;; Reference to one of the derivation's outputs, for gexps used in
464 ;; derivations.
465 (define-record-type <gexp-output>
466 (gexp-output name)
467 gexp-output?
468 (name gexp-output-name))
470 (define (write-gexp-output output port)
471 (match output
472 (($ <gexp-output> name)
473 (format port "#<gexp-output ~a>" name))))
475 (set-record-type-printer! <gexp-output> write-gexp-output)
477 (define (gexp-modules gexp)
478 "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is
479 false, meaning that GEXP is a plain Scheme object, return the empty list."
480 (if (gexp? gexp)
481 (delete-duplicates
482 (append (gexp-self-modules gexp)
483 (append-map (match-lambda
484 (($ <gexp-input> (? gexp? exp))
485 (gexp-modules exp))
486 (($ <gexp-input> (lst ...))
487 (append-map (lambda (item)
488 (if (gexp? item)
489 (gexp-modules item)
490 '()))
491 lst))
492 (_
493 '()))
494 (gexp-references gexp))))
495 '())) ;plain Scheme data type
497 (define* (lower-inputs inputs
498 #:key system target)
499 "Turn any package from INPUTS into a derivation for SYSTEM; return the
500 corresponding input list as a monadic value. When TARGET is true, use it as
501 the cross-compilation target triplet."
502 (with-monad %store-monad
503 (sequence %store-monad
504 (map (match-lambda
505 (((? struct? thing) sub-drv ...)
506 (mlet %store-monad ((drv (lower-object
507 thing system #:target target)))
508 (return `(,drv ,@sub-drv))))
509 (input
510 (return input)))
511 inputs))))
513 (define* (lower-reference-graphs graphs #:key system target)
514 "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
515 #:reference-graphs argument, lower it such that each INPUT is replaced by the
516 corresponding derivation."
517 (match graphs
518 (((file-names . inputs) ...)
519 (mlet %store-monad ((inputs (lower-inputs inputs
520 #:system system
521 #:target target)))
522 (return (map cons file-names inputs))))))
524 (define* (lower-references lst #:key system target)
525 "Based on LST, a list of output names and packages, return a list of output
526 names and file names suitable for the #:allowed-references argument to
527 'derivation'."
528 (with-monad %store-monad
529 (define lower
530 (match-lambda
531 ((? string? output)
532 (return output))
533 (($ <gexp-input> thing output native?)
534 (mlet %store-monad ((drv (lower-object thing system
535 #:target (if native?
536 #f target))))
537 (return (derivation->output-path drv output))))
538 (thing
539 (mlet %store-monad ((drv (lower-object thing system
540 #:target target)))
541 (return (derivation->output-path drv))))))
543 (sequence %store-monad (map lower lst))))
545 (define default-guile-derivation
546 ;; Here we break the abstraction by talking to the higher-level layer.
547 ;; Thus, do the resolution lazily to hide the circular dependency.
548 (let ((proc (delay
549 (let ((iface (resolve-interface '(guix packages))))
550 (module-ref iface 'default-guile-derivation)))))
551 (lambda (system)
552 ((force proc) system))))
554 (define* (gexp->derivation name exp
555 #:key
556 system (target 'current)
557 hash hash-algo recursive?
558 (env-vars '())
559 (modules '())
560 (module-path %load-path)
561 (guile-for-build (%guile-for-build))
562 (graft? (%graft?))
563 references-graphs
564 allowed-references disallowed-references
565 leaked-env-vars
566 local-build? (substitutable? #t)
567 deprecation-warnings
568 (script-name (string-append name "-builder")))
569 "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
570 derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME. When
571 TARGET is true, it is used as the cross-compilation target triplet for
572 packages referred to by EXP.
574 MODULES is deprecated in favor of 'with-imported-modules'. Its meaning is to
575 make MODULES available in the evaluation context of EXP; MODULES is a list of
576 names of Guile modules searched in MODULE-PATH to be copied in the store,
577 compiled, and made available in the load path during the execution of
578 EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
580 GRAFT? determines whether packages referred to by EXP should be grafted when
581 applicable.
583 When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the
584 following forms:
586 (FILE-NAME PACKAGE)
587 (FILE-NAME PACKAGE OUTPUT)
588 (FILE-NAME DERIVATION)
589 (FILE-NAME DERIVATION OUTPUT)
590 (FILE-NAME STORE-ITEM)
592 The right-hand-side of each element of REFERENCES-GRAPHS is automatically made
593 an input of the build process of EXP. In the build environment, each
594 FILE-NAME contains the reference graph of the corresponding item, in a simple
595 text format.
597 ALLOWED-REFERENCES must be either #f or a list of output names and packages.
598 In the latter case, the list denotes store items that the result is allowed to
599 refer to. Any reference to another store item will lead to a build error.
600 Similarly for DISALLOWED-REFERENCES, which can list items that must not be
601 referenced by the outputs.
603 DEPRECATION-WARNINGS determines whether to show deprecation warnings while
604 compiling modules. It can be #f, #t, or 'detailed.
606 The other arguments are as for 'derivation'."
607 (define %modules
608 (delete-duplicates
609 (append modules (gexp-modules exp))))
610 (define outputs (gexp-outputs exp))
612 (define (graphs-file-names graphs)
613 ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
614 (map (match-lambda
615 ;; TODO: Remove 'derivation?' special cases.
616 ((file-name (? derivation? drv))
617 (cons file-name (derivation->output-path drv)))
618 ((file-name (? derivation? drv) sub-drv)
619 (cons file-name (derivation->output-path drv sub-drv)))
620 ((file-name thing)
621 (cons file-name thing)))
622 graphs))
624 (mlet* %store-monad (;; The following binding forces '%current-system' and
625 ;; '%current-target-system' to be looked up at >>=
626 ;; time.
627 (graft? (set-grafting graft?))
629 (system -> (or system (%current-system)))
630 (target -> (if (eq? target 'current)
631 (%current-target-system)
632 target))
633 (normals (lower-inputs (gexp-inputs exp)
634 #:system system
635 #:target target))
636 (natives (lower-inputs (gexp-native-inputs exp)
637 #:system system
638 #:target #f))
639 (inputs -> (append normals natives))
640 (sexp (gexp->sexp exp
641 #:system system
642 #:target target))
643 (builder (text-file script-name
644 (object->string sexp)))
645 (modules (if (pair? %modules)
646 (imported-modules %modules
647 #:system system
648 #:module-path module-path
649 #:guile guile-for-build)
650 (return #f)))
651 (compiled (if (pair? %modules)
652 (compiled-modules %modules
653 #:system system
654 #:module-path module-path
655 #:guile guile-for-build
656 #:deprecation-warnings
657 deprecation-warnings)
658 (return #f)))
659 (graphs (if references-graphs
660 (lower-reference-graphs references-graphs
661 #:system system
662 #:target target)
663 (return #f)))
664 (allowed (if allowed-references
665 (lower-references allowed-references
666 #:system system
667 #:target target)
668 (return #f)))
669 (disallowed (if disallowed-references
670 (lower-references disallowed-references
671 #:system system
672 #:target target)
673 (return #f)))
674 (guile (if guile-for-build
675 (return guile-for-build)
676 (default-guile-derivation system))))
677 (mbegin %store-monad
678 (set-grafting graft?) ;restore the initial setting
679 (raw-derivation name
680 (string-append (derivation->output-path guile)
681 "/bin/guile")
682 `("--no-auto-compile"
683 ,@(if (pair? %modules)
684 `("-L" ,(derivation->output-path modules)
685 "-C" ,(derivation->output-path compiled))
686 '())
687 ,builder)
688 #:outputs outputs
689 #:env-vars env-vars
690 #:system system
691 #:inputs `((,guile)
692 (,builder)
693 ,@(if modules
694 `((,modules) (,compiled) ,@inputs)
695 inputs)
696 ,@(match graphs
697 (((_ . inputs) ...) inputs)
698 (_ '())))
699 #:hash hash #:hash-algo hash-algo #:recursive? recursive?
700 #:references-graphs (and=> graphs graphs-file-names)
701 #:allowed-references allowed
702 #:disallowed-references disallowed
703 #:leaked-env-vars leaked-env-vars
704 #:local-build? local-build?
705 #:substitutable? substitutable?))))
707 (define* (gexp-inputs exp #:key native?)
708 "Return the input list for EXP. When NATIVE? is true, return only native
709 references; otherwise, return only non-native references."
710 (define (add-reference-inputs ref result)
711 (match ref
712 (($ <gexp-input> (? gexp? exp) _ #t)
713 (if native?
714 (append (gexp-inputs exp)
715 (gexp-inputs exp #:native? #t)
716 result)
717 result))
718 (($ <gexp-input> (? gexp? exp) _ #f)
719 (append (gexp-inputs exp #:native? native?)
720 result))
721 (($ <gexp-input> (? string? str))
722 (if (direct-store-path? str)
723 (cons `(,str) result)
724 result))
725 (($ <gexp-input> (? struct? thing) output n?)
726 (if (and (eqv? n? native?) (lookup-compiler thing))
727 ;; THING is a derivation, or a package, or an origin, etc.
728 (cons `(,thing ,output) result)
729 result))
730 (($ <gexp-input> (lst ...) output n?)
731 (fold-right add-reference-inputs result
732 ;; XXX: For now, automatically convert LST to a list of
733 ;; gexp-inputs. Inherit N?.
734 (map (match-lambda
735 ((? gexp-input? x)
736 (%gexp-input (gexp-input-thing x)
737 (gexp-input-output x)
738 n?))
739 (x
740 (%gexp-input x "out" n?)))
741 lst)))
742 (_
743 ;; Ignore references to other kinds of objects.
744 result)))
746 (fold-right add-reference-inputs
747 '()
748 (gexp-references exp)))
750 (define gexp-native-inputs
751 (cut gexp-inputs <> #:native? #t))
753 (define (gexp-outputs exp)
754 "Return the outputs referred to by EXP as a list of strings."
755 (define (add-reference-output ref result)
756 (match ref
757 (($ <gexp-output> name)
758 (cons name result))
759 (($ <gexp-input> (? gexp? exp))
760 (append (gexp-outputs exp) result))
761 (($ <gexp-input> (lst ...) output native?)
762 ;; XXX: Automatically convert LST.
763 (add-reference-output (map (match-lambda
764 ((? gexp-input? x) x)
765 (x (%gexp-input x "out" native?)))
766 lst)
767 result))
768 ((lst ...)
769 (fold-right add-reference-output result lst))
770 (_
771 result)))
773 (delete-duplicates
774 (add-reference-output (gexp-references exp) '())))
776 (define* (gexp->sexp exp #:key
777 (system (%current-system))
778 (target (%current-target-system)))
779 "Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
780 and in the current monad setting (system type, etc.)"
781 (define* (reference->sexp ref #:optional native?)
782 (with-monad %store-monad
783 (match ref
784 (($ <gexp-output> output)
785 ;; Output file names are not known in advance but the daemon defines
786 ;; an environment variable for each of them at build time, so use
787 ;; that trick.
788 (return `((@ (guile) getenv) ,output)))
789 (($ <gexp-input> (? gexp? exp) output n?)
790 (gexp->sexp exp
791 #:system system
792 #:target (if (or n? native?) #f target)))
793 (($ <gexp-input> (refs ...) output n?)
794 (sequence %store-monad
795 (map (lambda (ref)
796 ;; XXX: Automatically convert REF to an gexp-input.
797 (reference->sexp
798 (if (gexp-input? ref)
799 ref
800 (%gexp-input ref "out" n?))
801 (or n? native?)))
802 refs)))
803 (($ <gexp-input> (? struct? thing) output n?)
804 (let ((target (if (or n? native?) #f target))
805 (expand (lookup-expander thing)))
806 (mlet %store-monad ((obj (lower-object thing system
807 #:target target)))
808 ;; OBJ must be either a derivation or a store file name.
809 (return (expand thing obj output)))))
810 (($ <gexp-input> x)
811 (return x))
812 (x
813 (return x)))))
815 (mlet %store-monad
816 ((args (sequence %store-monad
817 (map reference->sexp (gexp-references exp)))))
818 (return (apply (gexp-proc exp) args))))
820 (define (syntax-location-string s)
821 "Return a string representing the source code location of S."
822 (let ((props (syntax-source s)))
823 (if props
824 (let ((file (assoc-ref props 'filename))
825 (line (and=> (assoc-ref props 'line) 1+))
826 (column (assoc-ref props 'column)))
827 (if file
828 (simple-format #f "~a:~a:~a"
829 file line column)
830 (simple-format #f "~a:~a" line column)))
831 "<unknown location>")))
833 (define-syntax-parameter current-imported-modules
834 ;; Current list of imported modules.
835 (identifier-syntax '()))
837 (define-syntax-rule (with-imported-modules modules body ...)
838 "Mark the gexps defined in BODY... as requiring MODULES in their execution
839 environment."
840 (syntax-parameterize ((current-imported-modules
841 (identifier-syntax modules)))
842 body ...))
844 (define-syntax gexp
845 (lambda (s)
846 (define (collect-escapes exp)
847 ;; Return all the 'ungexp' present in EXP.
848 (let loop ((exp exp)
849 (result '()))
850 (syntax-case exp (ungexp
851 ungexp-splicing
852 ungexp-native
853 ungexp-native-splicing)
854 ((ungexp _)
855 (cons exp result))
856 ((ungexp _ _)
857 (cons exp result))
858 ((ungexp-splicing _ ...)
859 (cons exp result))
860 ((ungexp-native _ ...)
861 (cons exp result))
862 ((ungexp-native-splicing _ ...)
863 (cons exp result))
864 ((exp0 . exp)
865 (let ((result (loop #'exp0 result)))
866 (loop #'exp result)))
867 (_
868 result))))
870 (define (escape->ref exp)
871 ;; Turn 'ungexp' form EXP into a "reference".
872 (syntax-case exp (ungexp ungexp-splicing
873 ungexp-native ungexp-native-splicing
874 output)
875 ((ungexp output)
876 #'(gexp-output "out"))
877 ((ungexp output name)
878 #'(gexp-output name))
879 ((ungexp thing)
880 #'(%gexp-input thing "out" #f))
881 ((ungexp drv-or-pkg out)
882 #'(%gexp-input drv-or-pkg out #f))
883 ((ungexp-splicing lst)
884 #'(%gexp-input lst "out" #f))
885 ((ungexp-native thing)
886 #'(%gexp-input thing "out" #t))
887 ((ungexp-native drv-or-pkg out)
888 #'(%gexp-input drv-or-pkg out #t))
889 ((ungexp-native-splicing lst)
890 #'(%gexp-input lst "out" #t))))
892 (define (substitute-ungexp exp substs)
893 ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
894 ;; the corresponding form in SUBSTS.
895 (match (assoc exp substs)
896 ((_ id)
897 id)
898 (_ ;internal error
899 (with-syntax ((exp exp))
900 #'(syntax-error "error: no 'ungexp' substitution" exp)))))
902 (define (substitute-ungexp-splicing exp substs)
903 (syntax-case exp ()
904 ((exp rest ...)
905 (match (assoc #'exp substs)
906 ((_ id)
907 (with-syntax ((id id))
908 #`(append id
909 #,(substitute-references #'(rest ...) substs))))
910 (_
911 #'(syntax-error "error: no 'ungexp-splicing' substitution"
912 exp))))))
914 (define (substitute-references exp substs)
915 ;; Return a variant of EXP where all the cars of SUBSTS have been
916 ;; replaced by the corresponding cdr.
917 (syntax-case exp (ungexp ungexp-native
918 ungexp-splicing ungexp-native-splicing)
919 ((ungexp _ ...)
920 (substitute-ungexp exp substs))
921 ((ungexp-native _ ...)
922 (substitute-ungexp exp substs))
923 (((ungexp-splicing _ ...) rest ...)
924 (substitute-ungexp-splicing exp substs))
925 (((ungexp-native-splicing _ ...) rest ...)
926 (substitute-ungexp-splicing exp substs))
927 ((exp0 . exp)
928 #`(cons #,(substitute-references #'exp0 substs)
929 #,(substitute-references #'exp substs)))
930 (x #''x)))
932 (syntax-case s (ungexp output)
933 ((_ exp)
934 (let* ((escapes (delete-duplicates (collect-escapes #'exp)))
935 (formals (generate-temporaries escapes))
936 (sexp (substitute-references #'exp (zip escapes formals)))
937 (refs (map escape->ref escapes)))
938 #`(make-gexp (list #,@refs)
939 current-imported-modules
940 (lambda #,formals
941 #,sexp)))))))
943 \f
944 ;;;
945 ;;; Module handling.
946 ;;;
948 (define %utils-module
949 ;; This file provides 'mkdir-p', needed to implement 'imported-files' and
950 ;; other primitives below. Note: We give the file name relative to this
951 ;; file you are currently reading; 'search-path' could return a file name
952 ;; relative to the current working directory.
953 (local-file "build/utils.scm"
954 "build-utils.scm"))
956 (define* (imported-files files
957 #:key (name "file-import")
958 (system (%current-system))
959 (guile (%guile-for-build)))
960 "Return a derivation that imports FILES into STORE. FILES must be a list
961 of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the
962 resulting store path. FILE can be either a file name, or a file-like object,
963 as returned by 'local-file' for example."
964 (define file-pair
965 (match-lambda
966 ((final-path . (? string? file-name))
967 (mlet %store-monad ((file (interned-file file-name
968 (basename final-path))))
969 (return (list final-path file))))
970 ((final-path . file-like)
971 (mlet %store-monad ((file (lower-object file-like system)))
972 (return (list final-path file))))))
974 (mlet %store-monad ((files (sequence %store-monad
975 (map file-pair files))))
976 (define build
977 (gexp
978 (begin
979 (primitive-load (ungexp %utils-module)) ;for 'mkdir-p'
980 (use-modules (ice-9 match))
982 (mkdir (ungexp output)) (chdir (ungexp output))
983 (for-each (match-lambda
984 ((final-path store-path)
985 (mkdir-p (dirname final-path))
986 (symlink store-path final-path)))
987 '(ungexp files)))))
989 ;; TODO: Pass FILES as an environment variable so that BUILD remains
990 ;; exactly the same regardless of FILES: less disk space, and fewer
991 ;; 'add-to-store' RPCs.
992 (gexp->derivation name build
993 #:system system
994 #:guile-for-build guile
995 #:local-build? #t)))
997 (define* (imported-modules modules
998 #:key (name "module-import")
999 (system (%current-system))
1000 (guile (%guile-for-build))
1001 (module-path %load-path))
1002 "Return a derivation that contains the source files of MODULES, a list of
1003 module names such as `(ice-9 q)'. All of MODULES must be either names of
1004 modules to be found in the MODULE-PATH search path, or a module name followed
1005 by an arrow followed by a file-like object. For example:
1007 (imported-modules `((guix build utils)
1008 (guix gcrypt)
1009 ((guix config) => ,(scheme-file …))))
1011 In this example, the first two modules are taken from MODULE-PATH, and the
1012 last one is created from the given <scheme-file> object."
1013 (mlet %store-monad ((files
1014 (mapm %store-monad
1015 (match-lambda
1016 (((module ...) '=> file)
1017 (return
1018 (cons (module->source-file-name module)
1019 file)))
1020 ((module ...)
1021 (let ((f (module->source-file-name module)))
1022 (return
1023 (cons f (search-path* module-path f))))))
1024 modules)))
1025 (imported-files files #:name name #:system system
1026 #:guile guile)))
1028 (define* (compiled-modules modules
1029 #:key (name "module-import-compiled")
1030 (system (%current-system))
1031 (guile (%guile-for-build))
1032 (module-path %load-path)
1033 (deprecation-warnings #f))
1034 "Return a derivation that builds a tree containing the `.go' files
1035 corresponding to MODULES. All the MODULES are built in a context where
1036 they can refer to each other."
1037 (mlet %store-monad ((modules (imported-modules modules
1038 #:system system
1039 #:guile guile
1040 #:module-path
1041 module-path)))
1042 (define build
1043 (gexp
1044 (begin
1045 (primitive-load (ungexp %utils-module)) ;for 'mkdir-p'
1047 (use-modules (ice-9 ftw)
1048 (srfi srfi-26)
1049 (system base compile))
1051 (define (regular? file)
1052 (not (member file '("." ".."))))
1054 (define (process-directory directory output)
1055 (let ((entries (map (cut string-append directory "/" <>)
1056 (scandir directory regular?))))
1057 (for-each (lambda (entry)
1058 (if (file-is-directory? entry)
1059 (let ((output (string-append output "/"
1060 (basename entry))))
1061 (mkdir-p output)
1062 (process-directory entry output))
1063 (let* ((base (string-drop-right
1064 (basename entry)
1065 4)) ;.scm
1066 (output (string-append output "/" base
1067 ".go")))
1068 (compile-file entry
1069 #:output-file output
1070 #:opts
1071 %auto-compilation-options))))
1072 entries)))
1074 (set! %load-path (cons (ungexp modules) %load-path))
1075 (mkdir (ungexp output))
1076 (chdir (ungexp modules))
1077 (process-directory "." (ungexp output)))))
1079 ;; TODO: Pass MODULES as an environment variable.
1080 (gexp->derivation name build
1081 #:system system
1082 #:guile-for-build guile
1083 #:local-build? #t
1084 #:env-vars
1085 (case deprecation-warnings
1086 ((#f)
1087 '(("GUILE_WARN_DEPRECATED" . "no")))
1088 ((detailed)
1089 '(("GUILE_WARN_DEPRECATED" . "detailed")))
1090 (else
1091 '())))))
1093 \f
1094 ;;;
1095 ;;; Convenience procedures.
1096 ;;;
1098 (define (default-guile)
1099 ;; Lazily resolve 'guile-2.2' (not 'guile-final' because this is for
1100 ;; programs returned by 'program-file' and we don't want to keep references
1101 ;; to several Guile packages). This module must not refer to (gnu …)
1102 ;; modules directly, to avoid circular dependencies, hence this hack.
1103 (module-ref (resolve-interface '(gnu packages guile))
1104 'guile-2.2))
1106 (define (load-path-expression modules)
1107 "Return as a monadic value a gexp that sets '%load-path' and
1108 '%load-compiled-path' to point to MODULES, a list of module names."
1109 (mlet %store-monad ((modules (imported-modules modules))
1110 (compiled (compiled-modules modules)))
1111 (return (gexp (eval-when (expand load eval)
1112 (set! %load-path
1113 (cons (ungexp modules) %load-path))
1114 (set! %load-compiled-path
1115 (cons (ungexp compiled)
1116 %load-compiled-path)))))))
1118 (define* (gexp->script name exp
1119 #:key (guile (default-guile)))
1120 "Return an executable script NAME that runs EXP using GUILE, with EXP's
1121 imported modules in its search path."
1122 (mlet %store-monad ((set-load-path
1123 (load-path-expression (gexp-modules exp))))
1124 (gexp->derivation name
1125 (gexp
1126 (call-with-output-file (ungexp output)
1127 (lambda (port)
1128 ;; Note: that makes a long shebang. When the store
1129 ;; is /gnu/store, that fits within the 128-byte
1130 ;; limit imposed by Linux, but that may go beyond
1131 ;; when running tests.
1132 (format port
1133 "#!~a/bin/guile --no-auto-compile~%!#~%"
1134 (ungexp guile))
1136 (write '(ungexp set-load-path) port)
1137 (write '(ungexp exp) port)
1138 (chmod port #o555)))))))
1140 (define* (gexp->file name exp #:key (set-load-path? #t))
1141 "Return a derivation that builds a file NAME containing EXP. When
1142 SET-LOAD-PATH? is true, emit code in the resulting file to set '%load-path'
1143 and '%load-compiled-path' to honor EXP's imported modules."
1144 (match (if set-load-path? (gexp-modules exp) '())
1145 (() ;zero modules
1146 (gexp->derivation name
1147 (gexp
1148 (call-with-output-file (ungexp output)
1149 (lambda (port)
1150 (write '(ungexp exp) port))))
1151 #:local-build? #t
1152 #:substitutable? #f))
1153 ((modules ...)
1154 (mlet %store-monad ((set-load-path (load-path-expression modules)))
1155 (gexp->derivation name
1156 (gexp
1157 (call-with-output-file (ungexp output)
1158 (lambda (port)
1159 (write '(ungexp set-load-path) port)
1160 (write '(ungexp exp) port))))
1161 #:local-build? #t
1162 #:substitutable? #f)))))
1164 (define* (text-file* name #:rest text)
1165 "Return as a monadic value a derivation that builds a text file containing
1166 all of TEXT. TEXT may list, in addition to strings, objects of any type that
1167 can be used in a gexp: packages, derivations, local file objects, etc. The
1168 resulting store file holds references to all these."
1169 (define builder
1170 (gexp (call-with-output-file (ungexp output "out")
1171 (lambda (port)
1172 (display (string-append (ungexp-splicing text)) port)))))
1174 (gexp->derivation name builder
1175 #:local-build? #t
1176 #:substitutable? #f))
1178 (define* (mixed-text-file name #:rest text)
1179 "Return an object representing store file NAME containing TEXT. TEXT is a
1180 sequence of strings and file-like objects, as in:
1182 (mixed-text-file \"profile\"
1183 \"export PATH=\" coreutils \"/bin:\" grep \"/bin\")
1185 This is the declarative counterpart of 'text-file*'."
1186 (define build
1187 (gexp (call-with-output-file (ungexp output "out")
1188 (lambda (port)
1189 (display (string-append (ungexp-splicing text)) port)))))
1191 (computed-file name build))
1193 (define (file-union name files)
1194 "Return a <computed-file> that builds a directory containing all of FILES.
1195 Each item in FILES must be a two-element list where the first element is the
1196 file name to use in the new directory, and the second element is a gexp
1197 denoting the target file. Here's an example:
1199 (file-union \"etc\"
1200 `((\"hosts\" ,(plain-file \"hosts\"
1201 \"127.0.0.1 localhost\"))
1202 (\"bashrc\" ,(plain-file \"bashrc\"
1203 \"alias ls='ls --color'\"))))
1205 This yields an 'etc' directory containing these two files."
1206 (computed-file name
1207 (gexp
1208 (begin
1209 (mkdir (ungexp output))
1210 (chdir (ungexp output))
1211 (ungexp-splicing
1212 (map (match-lambda
1213 ((target source)
1214 (gexp
1215 (begin
1216 ;; Stat the source to abort early if it does
1217 ;; not exist.
1218 (stat (ungexp source))
1220 (symlink (ungexp source)
1221 (ungexp target))))))
1222 files))))))
1224 (define* (directory-union name things
1225 #:key (copy? #f) (quiet? #f))
1226 "Return a directory that is the union of THINGS, where THINGS is a list of
1227 file-like objects denoting directories. For example:
1229 (directory-union \"guile+emacs\" (list guile emacs))
1231 yields a directory that is the union of the 'guile' and 'emacs' packages.
1233 When HARD-LINKS? is true, create hard links instead of symlinks. When QUIET?
1234 is true, the derivation will not print anything."
1235 (define symlink
1236 (if copy?
1237 (gexp (lambda (old new)
1238 (if (file-is-directory? old)
1239 (symlink old new)
1240 (copy-file old new))))
1241 (gexp symlink)))
1243 (define log-port
1244 (if quiet?
1245 (gexp (%make-void-port "w"))
1246 (gexp (current-error-port))))
1248 (match things
1249 ((one)
1250 ;; Only one thing; return it.
1251 one)
1252 (_
1253 (computed-file name
1254 (with-imported-modules '((guix build union))
1255 (gexp (begin
1256 (use-modules (guix build union))
1257 (union-build (ungexp output)
1258 '(ungexp things)
1260 #:log-port (ungexp log-port)
1261 #:symlink (ungexp symlink)))))))))
1263 \f
1264 ;;;
1265 ;;; Syntactic sugar.
1266 ;;;
1268 (eval-when (expand load eval)
1269 (define* (read-ungexp chr port #:optional native?)
1270 "Read an 'ungexp' or 'ungexp-splicing' form from PORT. When NATIVE? is
1271 true, use 'ungexp-native' and 'ungexp-native-splicing' instead."
1272 (define unquote-symbol
1273 (match (peek-char port)
1274 (#\@
1275 (read-char port)
1276 (if native?
1277 'ungexp-native-splicing
1278 'ungexp-splicing))
1279 (_
1280 (if native?
1281 'ungexp-native
1282 'ungexp))))
1284 (match (read port)
1285 ((? symbol? symbol)
1286 (let ((str (symbol->string symbol)))
1287 (match (string-index-right str #\:)
1288 (#f
1289 `(,unquote-symbol ,symbol))
1290 (colon
1291 (let ((name (string->symbol (substring str 0 colon)))
1292 (output (substring str (+ colon 1))))
1293 `(,unquote-symbol ,name ,output))))))
1294 (x
1295 `(,unquote-symbol ,x))))
1297 (define (read-gexp chr port)
1298 "Read a 'gexp' form from PORT."
1299 `(gexp ,(read port)))
1301 ;; Extend the reader
1302 (read-hash-extend #\~ read-gexp)
1303 (read-hash-extend #\$ read-ungexp)
1304 (read-hash-extend #\+ (cut read-ungexp <> <> #t)))
1306 ;;; gexp.scm ends here