1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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)
42 local-file-absolute-file-name
95 gexp-error-invalid-input))
99 ;;; This module implements "G-expressions", or "gexps". Gexps are like
100 ;;; S-expressions (sexps), with two differences:
102 ;;; 1. References (un-quotations) to derivations or packages in a gexp are
103 ;;; replaced by the corresponding output file name; in addition, the
104 ;;; 'ungexp-native' unquote-like form allows code to explicitly refer to
105 ;;; the native code of a given package, in case of cross-compilation;
107 ;;; 2. Gexps embed information about the derivations they refer to.
109 ;;; Gexps make it easy to write to files Scheme code that refers to store
110 ;;; items, or to write Scheme code to build derivations.
115 (define-record-type <gexp>
116 (make-gexp references modules proc)
118 (references gexp-references) ;list of <gexp-input>
119 (modules gexp-self-modules) ;list of module names
120 (proc gexp-proc)) ;procedure
122 (define (write-gexp gexp port)
123 "Write GEXP on PORT."
124 (display "#<gexp " port)
126 ;; Try to write the underlying sexp. Now, this trick doesn't work when
127 ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure
128 ;; tries to use 'append' on that, which fails with wrong-type-arg.
130 (write (apply (gexp-proc gexp)
131 (gexp-references gexp))
134 (number->string (object-address gexp) 16)))
136 (set-record-type-printer! <gexp> write-gexp)
143 ;; Compiler for a type of objects that may be introduced in a gexp.
144 (define-record-type <gexp-compiler>
145 (gexp-compiler type lower expand)
147 (type gexp-compiler-type) ;record type descriptor
148 (lower gexp-compiler-lower)
149 (expand gexp-compiler-expand)) ;#f | DRV -> sexp
151 (define-condition-type &gexp-error &error
154 (define-condition-type &gexp-input-error &gexp-error
156 (input gexp-error-invalid-input))
159 (define %gexp-compilers
160 ;; 'eq?' mapping of record type descriptor to <gexp-compiler>.
161 (make-hash-table 20))
163 (define (default-expander thing obj output)
164 "This is the default expander for \"things\" that appear in gexps. It
165 returns its output file name of OBJ's OUTPUT."
168 (derivation->output-path drv output))
172 (define (register-compiler! compiler)
173 "Register COMPILER as a gexp compiler."
174 (hashq-set! %gexp-compilers
175 (gexp-compiler-type compiler) compiler))
177 (define (lookup-compiler object)
178 "Search for a compiler for OBJECT. Upon success, return the three argument
179 procedure to lower it; otherwise return #f."
180 (and=> (hashq-ref %gexp-compilers (struct-vtable object))
181 gexp-compiler-lower))
183 (define (lookup-expander object)
184 "Search for an expander for OBJECT. Upon success, return the three argument
185 procedure to expand it; otherwise return #f."
186 (and=> (hashq-ref %gexp-compilers (struct-vtable object))
187 gexp-compiler-expand))
189 (define* (lower-object obj
190 #:optional (system (%current-system))
192 "Return as a value in %STORE-MONAD the derivation or store item
193 corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
194 OBJ must be an object that has an associated gexp compiler, such as a
196 (match (lookup-compiler obj)
198 (raise (condition (&gexp-input-error (input obj)))))
200 (lower obj system target))))
202 (define-syntax define-gexp-compiler
203 (syntax-rules (=> compiler expander)
204 "Define NAME as a compiler for objects matching PREDICATE encountered in
207 In the simplest form of the macro, BODY must return a derivation for PARAM, an
208 object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is
209 #f except when cross-compiling.)
211 The more elaborate form allows you to specify an expander:
213 (define-gexp-compiler something something?
214 compiler => (lambda (param system target) ...)
215 expander => (lambda (param drv output) ...))
217 The expander specifies how an object is converted to its sexp representation."
218 ((_ (name (param record-type) system target) body ...)
219 (define-gexp-compiler name record-type
220 compiler => (lambda (param system target) body ...)
221 expander => default-expander))
227 (gexp-compiler record-type compile expand))
228 (register-compiler! name)))))
230 (define-gexp-compiler (derivation-compiler (drv <derivation>) system target)
231 ;; Derivations are the lowest-level representation, so this is the identity
233 (with-monad %store-monad
238 ;;; File declarations.
241 ;; A local file name. FILE is the file name the user entered, which can be a
242 ;; relative file name, and ABSOLUTE is a promise that computes its canonical
243 ;; absolute file name. We keep it in a promise to compute it lazily and avoid
244 ;; repeated 'stat' calls.
245 (define-record-type <local-file>
246 (%%local-file file absolute name recursive? select?)
248 (file local-file-file) ;string
249 (absolute %local-file-absolute-file-name) ;promise string
250 (name local-file-name) ;string
251 (recursive? local-file-recursive?) ;Boolean
252 (select? local-file-select?)) ;string stat -> Boolean
254 (define (true file stat) #t)
256 (define* (%local-file file promise #:optional (name (basename file))
257 #:key recursive? (select? true))
258 ;; This intermediate procedure is part of our ABI, but the underlying
259 ;; %%LOCAL-FILE is not.
260 (%%local-file file promise name recursive? select?))
262 (define (absolute-file-name file directory)
263 "Return the canonical absolute file name for FILE, which lives in the
264 vicinity of DIRECTORY."
266 (cond ((string-prefix? "/" file) file)
267 ((not directory) file)
268 ((string-prefix? "/" directory)
269 (string-append directory "/" file))
272 (define-syntax-rule (local-file file rest ...)
273 "Return an object representing local file FILE to add to the store; this
274 object can be used in a gexp. If FILE is a relative file name, it is looked
275 up relative to the source file where this form appears. FILE will be added to
276 the store under NAME--by default the base name of FILE.
278 When RECURSIVE? is true, the contents of FILE are added recursively; if FILE
279 designates a flat file and RECURSIVE? is true, its contents are added, and its
280 permission bits are kept.
282 When RECURSIVE? is true, call (SELECT? FILE STAT) for each directory entry,
283 where FILE is the entry's absolute file name and STAT is the result of
284 'lstat'; exclude entries for which SELECT? does not return true.
286 This is the declarative counterpart of the 'interned-file' monadic procedure."
288 (delay (absolute-file-name file (current-source-directory)))
291 (define (local-file-absolute-file-name file)
292 "Return the absolute file name for FILE, a <local-file> instance. A
293 'system-error' exception is raised if FILE could not be found."
294 (force (%local-file-absolute-file-name file)))
296 (define-gexp-compiler (local-file-compiler (file <local-file>) system target)
297 ;; "Compile" FILE by adding it to the store.
299 (($ <local-file> file (= force absolute) name recursive? select?)
300 ;; Canonicalize FILE so that if it's a symlink, it is resolved. Failing
301 ;; to do that, when RECURSIVE? is #t, we could end up creating a dangling
302 ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would
303 ;; just throw an error, both of which are inconvenient.
304 (interned-file absolute name
305 #:recursive? recursive? #:select? select?))))
307 (define-record-type <plain-file>
308 (%plain-file name content references)
310 (name plain-file-name) ;string
311 (content plain-file-content) ;string
312 (references plain-file-references)) ;list (currently unused)
314 (define (plain-file name content)
315 "Return an object representing a text file called NAME with the given
316 CONTENT (a string) to be added to the store.
318 This is the declarative counterpart of 'text-file'."
319 ;; XXX: For now just ignore 'references' because it's not clear how to use
320 ;; them in a declarative context.
321 (%plain-file name content '()))
323 (define-gexp-compiler (plain-file-compiler (file <plain-file>) system target)
324 ;; "Compile" FILE by adding it to the store.
326 (($ <plain-file> name content references)
327 (text-file name content references))))
329 (define-record-type <computed-file>
330 (%computed-file name gexp options)
332 (name computed-file-name) ;string
333 (gexp computed-file-gexp) ;gexp
334 (options computed-file-options)) ;list of arguments
336 (define* (computed-file name gexp
337 #:key (options '(#:local-build? #t)))
338 "Return an object representing the store item NAME, a file or directory
339 computed by GEXP. OPTIONS is a list of additional arguments to pass
340 to 'gexp->derivation'.
342 This is the declarative counterpart of 'gexp->derivation'."
343 (%computed-file name gexp options))
345 (define-gexp-compiler (computed-file-compiler (file <computed-file>)
347 ;; Compile FILE by returning a derivation whose build expression is its
350 (($ <computed-file> name gexp options)
351 (apply gexp->derivation name gexp options))))
353 (define-record-type <program-file>
354 (%program-file name gexp guile)
356 (name program-file-name) ;string
357 (gexp program-file-gexp) ;gexp
358 (guile program-file-guile)) ;package
360 (define* (program-file name gexp #:key (guile #f))
361 "Return an object representing the executable store item NAME that runs
362 GEXP. GUILE is the Guile package used to execute that script.
364 This is the declarative counterpart of 'gexp->script'."
365 (%program-file name gexp guile))
367 (define-gexp-compiler (program-file-compiler (file <program-file>)
369 ;; Compile FILE by returning a derivation that builds the script.
371 (($ <program-file> name gexp guile)
372 (gexp->script name gexp
373 #:guile (or guile (default-guile))))))
375 (define-record-type <scheme-file>
376 (%scheme-file name gexp)
378 (name scheme-file-name) ;string
379 (gexp scheme-file-gexp)) ;gexp
381 (define* (scheme-file name gexp)
382 "Return an object representing the Scheme file NAME that contains GEXP.
384 This is the declarative counterpart of 'gexp->file'."
385 (%scheme-file name gexp))
387 (define-gexp-compiler (scheme-file-compiler (file <scheme-file>)
389 ;; Compile FILE by returning a derivation that builds the file.
391 (($ <scheme-file> name gexp)
392 (gexp->file name gexp))))
394 ;; Appending SUFFIX to BASE's output file name.
395 (define-record-type <file-append>
396 (%file-append base suffix)
398 (base file-append-base) ;<package> | <derivation> | ...
399 (suffix file-append-suffix)) ;list of strings
401 (define (file-append base . suffix)
402 "Return a <file-append> object that expands to the concatenation of BASE and
404 (%file-append base suffix))
406 (define-gexp-compiler file-append-compiler <file-append>
407 compiler => (lambda (obj system target)
409 (($ <file-append> base _)
410 (lower-object base system #:target target))))
411 expander => (lambda (obj lowered output)
413 (($ <file-append> base suffix)
414 (let* ((expand (lookup-expander base))
415 (base (expand base lowered output)))
416 (string-append base (string-concatenate suffix)))))))
420 ;;; Inputs & outputs.
423 ;; The input of a gexp.
424 (define-record-type <gexp-input>
425 (%gexp-input thing output native?)
427 (thing gexp-input-thing) ;<package> | <origin> | <derivation> | ...
428 (output gexp-input-output) ;string
429 (native? gexp-input-native?)) ;Boolean
431 (define (write-gexp-input input port)
433 (($ <gexp-input> thing output #f)
434 (format port "#<gexp-input ~s:~a>" thing output))
435 (($ <gexp-input> thing output #t)
436 (format port "#<gexp-input native ~s:~a>" thing output))))
438 (set-record-type-printer! <gexp-input> write-gexp-input)
440 (define* (gexp-input thing ;convenience procedure
441 #:optional (output "out")
443 "Return a new <gexp-input> for the OUTPUT of THING; NATIVE? determines
444 whether this should be considered a \"native\" input or not."
445 (%gexp-input thing output native?))
447 ;; Reference to one of the derivation's outputs, for gexps used in
449 (define-record-type <gexp-output>
452 (name gexp-output-name))
454 (define (write-gexp-output output port)
456 (($ <gexp-output> name)
457 (format port "#<gexp-output ~a>" name))))
459 (set-record-type-printer! <gexp-output> write-gexp-output)
461 (define (gexp-modules gexp)
462 "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is
463 false, meaning that GEXP is a plain Scheme object, return the empty list."
466 (append (gexp-self-modules gexp)
467 (append-map (match-lambda
468 (($ <gexp-input> (? gexp? exp))
470 (($ <gexp-input> (lst ...))
471 (append-map (lambda (item)
478 (gexp-references gexp))))
479 '())) ;plain Scheme data type
481 (define* (lower-inputs inputs
483 "Turn any package from INPUTS into a derivation for SYSTEM; return the
484 corresponding input list as a monadic value. When TARGET is true, use it as
485 the cross-compilation target triplet."
486 (with-monad %store-monad
487 (sequence %store-monad
489 (((? struct? thing) sub-drv ...)
490 (mlet %store-monad ((drv (lower-object
491 thing system #:target target)))
492 (return `(,drv ,@sub-drv))))
497 (define* (lower-reference-graphs graphs #:key system target)
498 "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
499 #:reference-graphs argument, lower it such that each INPUT is replaced by the
500 corresponding derivation."
502 (((file-names . inputs) ...)
503 (mlet %store-monad ((inputs (lower-inputs inputs
506 (return (map cons file-names inputs))))))
508 (define* (lower-references lst #:key system target)
509 "Based on LST, a list of output names and packages, return a list of output
510 names and file names suitable for the #:allowed-references argument to
512 (with-monad %store-monad
517 (($ <gexp-input> thing output native?)
518 (mlet %store-monad ((drv (lower-object thing system
521 (return (derivation->output-path drv output))))
523 (mlet %store-monad ((drv (lower-object thing system
525 (return (derivation->output-path drv))))))
527 (sequence %store-monad (map lower lst))))
529 (define default-guile-derivation
530 ;; Here we break the abstraction by talking to the higher-level layer.
531 ;; Thus, do the resolution lazily to hide the circular dependency.
533 (let ((iface (resolve-interface '(guix packages))))
534 (module-ref iface 'default-guile-derivation)))))
536 ((force proc) system))))
538 (define* (gexp->derivation name exp
540 system (target 'current)
541 hash hash-algo recursive?
544 (module-path %load-path)
545 (guile-for-build (%guile-for-build))
548 allowed-references disallowed-references
550 local-build? (substitutable? #t)
551 (script-name (string-append name "-builder")))
552 "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
553 derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME. When
554 TARGET is true, it is used as the cross-compilation target triplet for
555 packages referred to by EXP.
557 MODULES is deprecated in favor of 'with-imported-modules'. Its meaning is to
558 make MODULES available in the evaluation context of EXP; MODULES is a list of
559 names of Guile modules searched in MODULE-PATH to be copied in the store,
560 compiled, and made available in the load path during the execution of
561 EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
563 GRAFT? determines whether packages referred to by EXP should be grafted when
566 When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the
570 (FILE-NAME PACKAGE OUTPUT)
571 (FILE-NAME DERIVATION)
572 (FILE-NAME DERIVATION OUTPUT)
573 (FILE-NAME STORE-ITEM)
575 The right-hand-side of each element of REFERENCES-GRAPHS is automatically made
576 an input of the build process of EXP. In the build environment, each
577 FILE-NAME contains the reference graph of the corresponding item, in a simple
580 ALLOWED-REFERENCES must be either #f or a list of output names and packages.
581 In the latter case, the list denotes store items that the result is allowed to
582 refer to. Any reference to another store item will lead to a build error.
583 Similarly for DISALLOWED-REFERENCES, which can list items that must not be
584 referenced by the outputs.
586 The other arguments are as for 'derivation'."
589 (append modules (gexp-modules exp))))
590 (define outputs (gexp-outputs exp))
592 (define (graphs-file-names graphs)
593 ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
595 ;; TODO: Remove 'derivation?' special cases.
596 ((file-name (? derivation? drv))
597 (cons file-name (derivation->output-path drv)))
598 ((file-name (? derivation? drv) sub-drv)
599 (cons file-name (derivation->output-path drv sub-drv)))
601 (cons file-name thing)))
604 (mlet* %store-monad (;; The following binding forces '%current-system' and
605 ;; '%current-target-system' to be looked up at >>=
607 (graft? (set-grafting graft?))
609 (system -> (or system (%current-system)))
610 (target -> (if (eq? target 'current)
611 (%current-target-system)
613 (normals (lower-inputs (gexp-inputs exp)
616 (natives (lower-inputs (gexp-native-inputs exp)
619 (inputs -> (append normals natives))
620 (sexp (gexp->sexp exp
623 (builder (text-file script-name
624 (object->string sexp)))
625 (modules (if (pair? %modules)
626 (imported-modules %modules
628 #:module-path module-path
629 #:guile guile-for-build)
631 (compiled (if (pair? %modules)
632 (compiled-modules %modules
634 #:module-path module-path
635 #:guile guile-for-build)
637 (graphs (if references-graphs
638 (lower-reference-graphs references-graphs
642 (allowed (if allowed-references
643 (lower-references allowed-references
647 (disallowed (if disallowed-references
648 (lower-references disallowed-references
652 (guile (if guile-for-build
653 (return guile-for-build)
654 (default-guile-derivation system))))
656 (set-grafting graft?) ;restore the initial setting
658 (string-append (derivation->output-path guile)
660 `("--no-auto-compile"
661 ,@(if (pair? %modules)
662 `("-L" ,(derivation->output-path modules)
663 "-C" ,(derivation->output-path compiled))
672 `((,modules) (,compiled) ,@inputs)
675 (((_ . inputs) ...) inputs)
677 #:hash hash #:hash-algo hash-algo #:recursive? recursive?
678 #:references-graphs (and=> graphs graphs-file-names)
679 #:allowed-references allowed
680 #:disallowed-references disallowed
681 #:leaked-env-vars leaked-env-vars
682 #:local-build? local-build?
683 #:substitutable? substitutable?))))
685 (define* (gexp-inputs exp #:key native?)
686 "Return the input list for EXP. When NATIVE? is true, return only native
687 references; otherwise, return only non-native references."
688 (define (add-reference-inputs ref result)
690 (($ <gexp-input> (? gexp? exp) _ #t)
692 (append (gexp-inputs exp)
693 (gexp-inputs exp #:native? #t)
696 (($ <gexp-input> (? gexp? exp) _ #f)
697 (append (gexp-inputs exp #:native? native?)
699 (($ <gexp-input> (? string? str))
700 (if (direct-store-path? str)
701 (cons `(,str) result)
703 (($ <gexp-input> (? struct? thing) output n?)
704 (if (and (eqv? n? native?) (lookup-compiler thing))
705 ;; THING is a derivation, or a package, or an origin, etc.
706 (cons `(,thing ,output) result)
708 (($ <gexp-input> (lst ...) output n?)
709 (if (eqv? native? n?)
710 (fold-right add-reference-inputs result
711 ;; XXX: For now, automatically convert LST to a list of
714 ((? gexp-input? x) x)
715 (x (%gexp-input x "out" (or n? native?))))
719 ;; Ignore references to other kinds of objects.
722 (fold-right add-reference-inputs
724 (gexp-references exp)))
726 (define gexp-native-inputs
727 (cut gexp-inputs <> #:native? #t))
729 (define (gexp-outputs exp)
730 "Return the outputs referred to by EXP as a list of strings."
731 (define (add-reference-output ref result)
733 (($ <gexp-output> name)
735 (($ <gexp-input> (? gexp? exp))
736 (append (gexp-outputs exp) result))
737 (($ <gexp-input> (lst ...) output native?)
738 ;; XXX: Automatically convert LST.
739 (add-reference-output (map (match-lambda
740 ((? gexp-input? x) x)
741 (x (%gexp-input x "out" native?)))
745 (fold-right add-reference-output result lst))
750 (add-reference-output (gexp-references exp) '())))
752 (define* (gexp->sexp exp #:key
753 (system (%current-system))
754 (target (%current-target-system)))
755 "Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
756 and in the current monad setting (system type, etc.)"
757 (define* (reference->sexp ref #:optional native?)
758 (with-monad %store-monad
760 (($ <gexp-output> output)
761 ;; Output file names are not known in advance but the daemon defines
762 ;; an environment variable for each of them at build time, so use
764 (return `((@ (guile) getenv) ,output)))
765 (($ <gexp-input> (? gexp? exp) output n?)
768 #:target (if (or n? native?) #f target)))
769 (($ <gexp-input> (refs ...) output n?)
770 (sequence %store-monad
772 ;; XXX: Automatically convert REF to an gexp-input.
774 (if (gexp-input? ref)
776 (%gexp-input ref "out" n?))
779 (($ <gexp-input> (? struct? thing) output n?)
780 (let ((target (if (or n? native?) #f target))
781 (expand (lookup-expander thing)))
782 (mlet %store-monad ((obj (lower-object thing system
784 ;; OBJ must be either a derivation or a store file name.
785 (return (expand thing obj output)))))
792 ((args (sequence %store-monad
793 (map reference->sexp (gexp-references exp)))))
794 (return (apply (gexp-proc exp) args))))
796 (define (syntax-location-string s)
797 "Return a string representing the source code location of S."
798 (let ((props (syntax-source s)))
800 (let ((file (assoc-ref props 'filename))
801 (line (and=> (assoc-ref props 'line) 1+))
802 (column (assoc-ref props 'column)))
804 (simple-format #f "~a:~a:~a"
806 (simple-format #f "~a:~a" line column)))
807 "<unknown location>")))
809 (define-syntax-parameter current-imported-modules
810 ;; Current list of imported modules.
811 (identifier-syntax '()))
813 (define-syntax-rule (with-imported-modules modules body ...)
814 "Mark the gexps defined in BODY... as requiring MODULES in their execution
816 (syntax-parameterize ((current-imported-modules
817 (identifier-syntax modules)))
822 (define (collect-escapes exp)
823 ;; Return all the 'ungexp' present in EXP.
826 (syntax-case exp (ungexp
829 ungexp-native-splicing)
834 ((ungexp-splicing _ ...)
836 ((ungexp-native _ ...)
838 ((ungexp-native-splicing _ ...)
841 (let ((result (loop #'exp0 result)))
842 (loop #'exp result)))
846 (define (escape->ref exp)
847 ;; Turn 'ungexp' form EXP into a "reference".
848 (syntax-case exp (ungexp ungexp-splicing
849 ungexp-native ungexp-native-splicing
852 #'(gexp-output "out"))
853 ((ungexp output name)
854 #'(gexp-output name))
856 #'(%gexp-input thing "out" #f))
857 ((ungexp drv-or-pkg out)
858 #'(%gexp-input drv-or-pkg out #f))
859 ((ungexp-splicing lst)
860 #'(%gexp-input lst "out" #f))
861 ((ungexp-native thing)
862 #'(%gexp-input thing "out" #t))
863 ((ungexp-native drv-or-pkg out)
864 #'(%gexp-input drv-or-pkg out #t))
865 ((ungexp-native-splicing lst)
866 #'(%gexp-input lst "out" #t))))
868 (define (substitute-ungexp exp substs)
869 ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
870 ;; the corresponding form in SUBSTS.
871 (match (assoc exp substs)
875 (with-syntax ((exp exp))
876 #'(syntax-error "error: no 'ungexp' substitution" exp)))))
878 (define (substitute-ungexp-splicing exp substs)
881 (match (assoc #'exp substs)
883 (with-syntax ((id id))
885 #,(substitute-references #'(rest ...) substs))))
887 #'(syntax-error "error: no 'ungexp-splicing' substitution"
890 (define (substitute-references exp substs)
891 ;; Return a variant of EXP where all the cars of SUBSTS have been
892 ;; replaced by the corresponding cdr.
893 (syntax-case exp (ungexp ungexp-native
894 ungexp-splicing ungexp-native-splicing)
896 (substitute-ungexp exp substs))
897 ((ungexp-native _ ...)
898 (substitute-ungexp exp substs))
899 (((ungexp-splicing _ ...) rest ...)
900 (substitute-ungexp-splicing exp substs))
901 (((ungexp-native-splicing _ ...) rest ...)
902 (substitute-ungexp-splicing exp substs))
904 #`(cons #,(substitute-references #'exp0 substs)
905 #,(substitute-references #'exp substs)))
908 (syntax-case s (ungexp output)
910 (let* ((escapes (delete-duplicates (collect-escapes #'exp)))
911 (formals (generate-temporaries escapes))
912 (sexp (substitute-references #'exp (zip escapes formals)))
913 (refs (map escape->ref escapes)))
914 #`(make-gexp (list #,@refs)
915 current-imported-modules
924 (define %utils-module
925 ;; This file provides 'mkdir-p', needed to implement 'imported-files' and
926 ;; other primitives below. Note: We give the file name relative to this
927 ;; file you are currently reading; 'search-path' could return a file name
928 ;; relative to the current working directory.
929 (local-file "build/utils.scm"
932 (define* (imported-files files
933 #:key (name "file-import")
934 (system (%current-system))
935 (guile (%guile-for-build)))
936 "Return a derivation that imports FILES into STORE. FILES must be a list
937 of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the
938 resulting store path. FILE can be either a file name, or a file-like object,
939 as returned by 'local-file' for example."
942 ((final-path . (? string? file-name))
943 (mlet %store-monad ((file (interned-file file-name
944 (basename final-path))))
945 (return (list final-path file))))
946 ((final-path . file-like)
947 (mlet %store-monad ((file (lower-object file-like system)))
948 (return (list final-path file))))))
950 (mlet %store-monad ((files (sequence %store-monad
951 (map file-pair files))))
955 (primitive-load (ungexp %utils-module)) ;for 'mkdir-p'
956 (use-modules (ice-9 match))
958 (mkdir (ungexp output)) (chdir (ungexp output))
959 (for-each (match-lambda
960 ((final-path store-path)
961 (mkdir-p (dirname final-path))
962 (symlink store-path final-path)))
965 ;; TODO: Pass FILES as an environment variable so that BUILD remains
966 ;; exactly the same regardless of FILES: less disk space, and fewer
967 ;; 'add-to-store' RPCs.
968 (gexp->derivation name build
970 #:guile-for-build guile
973 (define* (imported-modules modules
974 #:key (name "module-import")
975 (system (%current-system))
976 (guile (%guile-for-build))
977 (module-path %load-path))
978 "Return a derivation that contains the source files of MODULES, a list of
979 module names such as `(ice-9 q)'. All of MODULES must be either names of
980 modules to be found in the MODULE-PATH search path, or a module name followed
981 by an arrow followed by a file-like object. For example:
983 (imported-modules `((guix build utils)
985 ((guix config) => ,(scheme-file …))))
987 In this example, the first two modules are taken from MODULE-PATH, and the
988 last one is created from the given <scheme-file> object."
989 (mlet %store-monad ((files
992 (((module ...) '=> file)
994 (cons (module->source-file-name module)
997 (let ((f (module->source-file-name module)))
999 (cons f (search-path* module-path f))))))
1001 (imported-files files #:name name #:system system
1004 (define* (compiled-modules modules
1005 #:key (name "module-import-compiled")
1006 (system (%current-system))
1007 (guile (%guile-for-build))
1008 (module-path %load-path))
1009 "Return a derivation that builds a tree containing the `.go' files
1010 corresponding to MODULES. All the MODULES are built in a context where
1011 they can refer to each other."
1012 (mlet %store-monad ((modules (imported-modules modules
1020 (primitive-load (ungexp %utils-module)) ;for 'mkdir-p'
1022 (use-modules (ice-9 ftw)
1024 (system base compile))
1026 (define (regular? file)
1027 (not (member file '("." ".."))))
1029 (define (process-directory directory output)
1030 (let ((entries (map (cut string-append directory "/" <>)
1031 (scandir directory regular?))))
1032 (for-each (lambda (entry)
1033 (if (file-is-directory? entry)
1034 (let ((output (string-append output "/"
1037 (process-directory entry output))
1038 (let* ((base (string-drop-right
1041 (output (string-append output "/" base
1044 #:output-file output
1046 %auto-compilation-options))))
1049 (set! %load-path (cons (ungexp modules) %load-path))
1050 (mkdir (ungexp output))
1051 (chdir (ungexp modules))
1052 (process-directory "." (ungexp output)))))
1054 ;; TODO: Pass MODULES as an environment variable.
1055 (gexp->derivation name build
1057 #:guile-for-build guile
1058 #:local-build? #t)))
1062 ;;; Convenience procedures.
1065 (define (default-guile)
1066 ;; Lazily resolve 'guile-final'. This module must not refer to (gnu …)
1067 ;; modules directly, to avoid circular dependencies, hence this hack.
1068 (module-ref (resolve-interface '(gnu packages commencement))
1071 (define (load-path-expression modules)
1072 "Return as a monadic value a gexp that sets '%load-path' and
1073 '%load-compiled-path' to point to MODULES, a list of module names."
1074 (mlet %store-monad ((modules (imported-modules modules))
1075 (compiled (compiled-modules modules)))
1076 (return (gexp (eval-when (expand load eval)
1078 (cons (ungexp modules) %load-path))
1079 (set! %load-compiled-path
1080 (cons (ungexp compiled)
1081 %load-compiled-path)))))))
1083 (define* (gexp->script name exp
1084 #:key (guile (default-guile)))
1085 "Return an executable script NAME that runs EXP using GUILE, with EXP's
1086 imported modules in its search path."
1087 (mlet %store-monad ((set-load-path
1088 (load-path-expression (gexp-modules exp))))
1089 (gexp->derivation name
1091 (call-with-output-file (ungexp output)
1093 ;; Note: that makes a long shebang. When the store
1094 ;; is /gnu/store, that fits within the 128-byte
1095 ;; limit imposed by Linux, but that may go beyond
1096 ;; when running tests.
1098 "#!~a/bin/guile --no-auto-compile~%!#~%"
1101 (write '(ungexp set-load-path) port)
1102 (write '(ungexp exp) port)
1103 (chmod port #o555)))))))
1105 (define* (gexp->file name exp #:key (set-load-path? #t))
1106 "Return a derivation that builds a file NAME containing EXP. When
1107 SET-LOAD-PATH? is true, emit code in the resulting file to set '%load-path'
1108 and '%load-compiled-path' to honor EXP's imported modules."
1109 (match (if set-load-path? (gexp-modules exp) '())
1111 (gexp->derivation name
1113 (call-with-output-file (ungexp output)
1115 (write '(ungexp exp) port))))
1117 #:substitutable? #f))
1119 (mlet %store-monad ((set-load-path (load-path-expression modules)))
1120 (gexp->derivation name
1122 (call-with-output-file (ungexp output)
1124 (write '(ungexp set-load-path) port)
1125 (write '(ungexp exp) port))))
1127 #:substitutable? #f)))))
1129 (define* (text-file* name #:rest text)
1130 "Return as a monadic value a derivation that builds a text file containing
1131 all of TEXT. TEXT may list, in addition to strings, objects of any type that
1132 can be used in a gexp: packages, derivations, local file objects, etc. The
1133 resulting store file holds references to all these."
1135 (gexp (call-with-output-file (ungexp output "out")
1137 (display (string-append (ungexp-splicing text)) port)))))
1139 (gexp->derivation name builder
1141 #:substitutable? #f))
1143 (define* (mixed-text-file name #:rest text)
1144 "Return an object representing store file NAME containing TEXT. TEXT is a
1145 sequence of strings and file-like objects, as in:
1147 (mixed-text-file \"profile\"
1148 \"export PATH=\" coreutils \"/bin:\" grep \"/bin\")
1150 This is the declarative counterpart of 'text-file*'."
1152 (gexp (call-with-output-file (ungexp output "out")
1154 (display (string-append (ungexp-splicing text)) port)))))
1156 (computed-file name build))
1160 ;;; Syntactic sugar.
1163 (eval-when (expand load eval)
1164 (define* (read-ungexp chr port #:optional native?)
1165 "Read an 'ungexp' or 'ungexp-splicing' form from PORT. When NATIVE? is
1166 true, use 'ungexp-native' and 'ungexp-native-splicing' instead."
1167 (define unquote-symbol
1168 (match (peek-char port)
1172 'ungexp-native-splicing
1181 (let ((str (symbol->string symbol)))
1182 (match (string-index-right str #\:)
1184 `(,unquote-symbol ,symbol))
1186 (let ((name (string->symbol (substring str 0 colon)))
1187 (output (substring str (+ colon 1))))
1188 `(,unquote-symbol ,name ,output))))))
1190 `(,unquote-symbol ,x))))
1192 (define (read-gexp chr port)
1193 "Read a 'gexp' form from PORT."
1194 `(gexp ,(read port)))
1196 ;; Extend the reader
1197 (read-hash-extend #\~ read-gexp)
1198 (read-hash-extend #\$ read-ungexp)
1199 (read-hash-extend #\+ (cut read-ungexp <> <> #t)))
1201 ;;; gexp.scm ends here