guix/gexp.scm

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