guix/gexp.scm

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